我无法创建数组，我的删除重复项也有问题

Posted 2023-03-06

【中文标题】我无法创建数组，我的删除重复项也有问题

【英文标题】：I am not able create array and there is something wrong with my remove duplicates also

【发布时间】：2018-04-21 09:52:04

【问题描述】：

请看附件了解我的查询的输出（我在图像中提到了标题以供您理解，实际上，输出的标题是空白的）。

我的代码仅在 k 的第一次迭代中运行，然后在下面提到的行中出现错误“下标超出范围。此外，我的删除重复项没有在代码中提供所需的输出。是因为空格或者我该如何解决这两个问题？

我是第一次使用数组。

Dim MoNameArr
Dim arr()
Dim ColLtrg, ColLtrgp, GPLLastCol, GPLLastRow as Long
i = 0
ReDim arr(0)

With wsg

    For k = 2 To GPLLastRow

        .Cells(k, GPLLastCol + 1).Value = .Cells(k, 2).Value & .Cells(k, 3).Value

        If .Cells(k, 4).Value = .Cells(k, 8).Value And .Cells(k, 4).Value = .Cells(k, 9).Value Then
            i = k - 2
            arr(i) = .Cells(k, 2).Value 'Subscript out of range error
            .Cells(k, GPLLastCol + 2).Value = arr(i)
            ReDim Preserve arr(i)
        End If

    Next k

    ColLtrg = Replace(.Cells(1, GPLLastCol + 2).Address(True, False), "$1", "")

    .Range(ColLtrg & "1:" & ColLtrg & GPLLastRow).RemoveDuplicates Columns:=1, Header:=xlNo
    MoNameArr = .Range("AD1:AD" & GetLastRow(wsg, GPLLastCol + 2))

End With

For Each Item In MoNameArr
    'Do something
Next Item


Public Function GetLastCol(ByVal ws As Worksheet, rowNum As Long) As Long
  With ws
    GetLastCol = .Cells(rowNum, Columns.Count).End(xlToLeft).Column
  End With
End Function

Public Function GetLastRow(ByVal ws As Worksheet, colNum As Long) As Long
  With ws
    GetLastRow = .Cells(Rows.Count, colNum).End(xlUp).Row
  End With
End Function

【问题讨论】：

谁投了反对票，如果您不能提供解决方案，请提供原因。我正在学习 vba，并且第一次遇到数组（无论如何都在做我的第二个作业），我无法通过阅读与数组相关的文章来弄清楚很多东西。

只是想注意：这个声明：Dim ColLtrg, ColLtrgp, GPLLastCol, GPLLastRow as Long 只是将GPLLastRow 声明为Long。其他默认为Variant。

【参考方案1】：

下标超出范围错误很可能来自您如何将数组定义到应用程序。我非常有信心，当您遇到该错误时，i 0.

注意：

当使用ReDim Preserve arr(i) 时，您需要在尝试将变量放入arr(i) 之前声明这个。此外，由于i 基于与单元格引用相关的k，因此您的数组将在您决定保留的值之间产生许多空项目槽。

---

说明

---

在这一行：

ReDim arr(0)

您告诉应用程序将arr 定义为上边界为0 的一维数组，因为默认的下边界通常也是0；您实际上是在告诉应用程序为 1 对象定义具有空间的数组。

将通过代码arr(0)

访问

---

如果您使用了以下行：

ReDim arr(1 to 10)

您会告诉应用程序将数组定义为一维数组，其中有 10 个对象的空间，第一个通过arr(1) 访问，最后一个通过arr(10) 访问。

---

下一行也将数组定义为一维数组，包含 10 个对象：

ReDim arr(9)

但是，这一次，第一个对象可以通过arr(0) 访问，最后一个对象可以通过arr(9) 访问。 （这是基于您尚未在 vba 中声明默认下限应为 1 的假设。）

---

你可以像这样定义一个二维数组：

ReDim arr(0 to 5, 0 to 15)

这个数组将包含 96 个项目。但是，要访问它们，您必须使用 arr(0,4) 或 arr(2,15) 之类的代码。

---

备选方案

---

如果我可以推荐一种替代方法，您是否考虑过使用字典对象而不是数组？

由于我不知道您对数据所做的一切，这可能不是最佳解决方案。但是，如果您的主要目标是从列中删除重复值并压缩列，我认为字典应该可以很好地工作。

*** 上的这个 Q/A 提供了一些关于字典、集合和数组的很好的基本信息。

我考虑字典的主要原因是因为字典对象有一个.Exists 方法，您可以在其中传递一个值（作为键）并查看字典是否已经有了它。然后您可以添加任何新项目并忽略重复的项目。

假设dict 是一个字典对象，rng 是您正在检查的循环变量单元格/范围对象，您可以使用以下代码来收集不同值和计数的列表：

For each rng in SomeRangeVariable
    With dict
        If .Exists(rng.Value) Then
            .Items(rng.Value) = .Items(rng.Value) + 1
        Else
            .Add Key:=rng.Value, Item:=1
        End If
    End With
Next rng

【参考方案2】：

您使用单个元素实例化从零开始的一维数组arr；例如arr(0 to 0).

在循环的第一次迭代中，k 是 2，i = k - 2 所以i 是零。如果条件满足，数组中有空间存放.Cells(k, 2) 值。

ReDim 语句在这里什么都不做，因为i 为零，而ubound(arr) 已经为零。

在下一次迭代中，直到满足条件为止，ubound(arr) 仍然为零，但 k 已经增长，并且由于 i 基于 k，它也会增长。任何将.Cells(k, 2) 值放入arr 的i 位置的尝试都将导致“下标超出范围”。

解决方案：在尝试填充数组之前使用 Preserve 进行 Redim。

For k = 2 To GPLLastRow
    .Cells(k, GPLLastCol + 1).Value = .Cells(k, 2).Value & .Cells(k, 3).Value
    If .Cells(k, 4).Value = .Cells(k, 8).Value And .Cells(k, 4).Value = .Cells(k, 9).Value Then
        i = k - 2
        ReDim Preserve arr(i)
        arr(i) = .Cells(k, 2).Value 'Subscript not out of range anymore
        .Cells(k, GPLLastCol + 2).Value = arr(i)
    End If
Next k

【参考方案3】：

非常感谢 Jeeped 和 Mistella 的深入解释，让我意识到我的代码中存在漏洞。我现在可以使用 2 种方法来做到这一点。一个带数组，一个不带数组。不能说其中是否有人比另一个更好，但它们都对我有用。我稍后也会尝试字典方法。

'使用数组的方法/Redim 保存

i = 0
With wsg
    For k = 2 To GPLLastRow
    On Error Resume Next 'For handling #N/A values
        .Cells(k, GPLLastCol + 1).Value = .Cells(k, 2).Value & .Cells(k, 3).Value
        If .Cells(k, 4).Value = .Cells(k, 8).Value And .Cells(k, 4).Value = .Cells(k, 9).Value Then
            ReDim Preserve arr(i)
            arr(i) = .Cells(k, 2).Value 'Subscript not out of range anymore
            .Cells(i + 1, GPLLastCol + 2).Value = arr(i)
            i = i + 1
        End If
    On Error GoTo 0
    Next k

    ColLtrgp = Replace(.Cells(1, GPLLastCol + 1).Address(True, False), "$1", "")
    ColLtrg = Replace(.Cells(1, GPLLastCol + 2).Address(True, False), "$1", "")

    .Range(ColLtrg & "1:" & ColLtrg & GetLastRow(wsg, GPLLastCol + 2)).RemoveDuplicates Columns:=1, Header:=xlNo
    MoNameArr = .Range(ColLtrg & "1:" & ColLtrg & GetLastRow(wsg, GPLLastCol + 2))
End With

'不使用数组的方法/Redim保留

i = 1
With wsg
    For k = 2 To GPLLastRow
    On Error Resume Next
        .Cells(k, GPLLastCol + 1).Value = .Cells(k, 2).Value & .Cells(k, 3).Value
        If .Cells(k, 4).Value = .Cells(k, 8).Value And .Cells(k, 4).Value = .Cells(k, 9).Value Then
            .Cells(i, GPLLastCol + 2).Value = .Cells(k, 2).Value
            i = i + 1
        End If
    On Error GoTo 0
    Next k

    ColLtrgp = Replace(.Cells(1, GPLLastCol + 1).Address(True, False), "$1", "")
    ColLtrg = Replace(.Cells(1, GPLLastCol + 2).Address(True, False), "$1", "")

    .Range(ColLtrg & "1:" & ColLtrg & GetLastRow(wsg, GPLLastCol + 2)).RemoveDuplicates Columns:=1, Header:=xlNo
    MoNameArr = .Range(ColLtrg & "1:" & ColLtrg & GetLastRow(wsg, GPLLastCol + 2))
End With