Question

我一直在研究一个宏，它总结了我工作簿中多个工作表的数据。为了知道在摘要表中使用哪些列，我需要首先从工作表的第一列中提取所有唯一值。

这个想法是它将遍历工作表并定义一个范围，然后它将循环遍历范围中的每个单元格，检查该单元格的值是否已经在数组中，如果没有复制并粘贴它并添加它到阵列。

不幸的是，我在错误的“有效区域之外的索引”中得到了应该将单元格值添加到数组的行。

ReDim Preserve uniqueVal(1 To UBound(uniqueVal) + 1) As Variant

我从问题https://superuser.com/questions/808798/excel-vba-adding-an-element-to-the-end-of-an-array中获取了该特定代码。

以下是整个代码供参考。

Private Sub CommandButton24_Click()

    Dim xSheet As Worksheet
    Dim DestSh As Worksheet
    Dim Last As Long
    Dim copyRng As Range
    Dim destRng As Range
    Dim cRange As Range
    Dim c As Range
    Dim uniqueVal() As Variant

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    'Delete the summary worksheet if it exists.
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Summary").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    ' Add a worksheet with the name "Summary"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Summary"
    Set destRng = DestSh.Range("A1")

    'Define inital array values
    uniqueVal = Array("Account by Type", "Total")

    ' Loop through all worksheets and copy the data to the
    ' summary worksheet.
    For Each xSheet In ActiveWorkbook.Worksheets

        If InStr(1, xSheet.Name, "ACCOUNT") And xSheet.Range("B1") <> "No Summary Available" Then _

            Set copyRng = xSheet.Range("A:A")

            For Each c In copyRng.SpecialCells(xlCellTypeVisible)

                If Len(c) <> 0 And Not ISIN(c, uniqueVal) Then _

                    'Copy to destination Range
                    c.Copy destRng
                    'move destination Range
                    Set destRng = destRng.Offset(0, 1)
                    'change / adjust the size of array
                    ReDim Preserve uniqueVal(1 To UBound(uniqueVal) + 1) As Variant
                    'add value on the end of the array
                    uniqueVal(UBound(uniqueVal)) = c.Value

                End If

            Next c

        End If

    Next xSheet

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With


End Sub

Answer 1

默认情况下，Excel VBA中的数组以索引0开头，而不是索引1。您可以通过检查数组内容对此进行测试：您的第一个字符串"Account by Type"应位于uniqueval(0)上，而不是uniqueval(1)上。

解决这个问题的两种方法：

将Option Base 1添加到模块顶部或
将ReDim Preserve uniqueval(1 To UBound(uniqueval) + 1)更改为ReDim Preserve uniqueval(0 To UBound(uniqueval) + 1)

由您决定选择哪一个，但后者更加清晰，因为您不必在模块级别上使用数组选项。

在我看来，你实际上并没有使用数组＆＃39;内容呢。如果您稍后再做，只需循环For i = LBound(uniqueval) To UBound(uniqueval) - 在这种情况下，它与您选择的选项无关。

Answer 2

在第一个循环中，uniqueVal没有Ubound。这就是它失败的原因。因此，您应首先将其重命名为Redim uniqueVal（1到1），然后写入Ubound并在此后增加大小。这总会让你在顶部留下一个空白元素，你可以在最后删除它。更好（因为它运行得更快）是将uniqueVal调暗到可能的最大数，然后用计数器设置当前索引，如i = i + 1，并在结尾处执行Redim Preserve uniqueVal（i），从而切断所有未使用的元素。

代码行末尾的下划线表示该行在逻辑上继续在下一行中。例如，

If 1 <> 2 Then _
    Debug.Print "All is well"

这与If 1 <> 2 Then Debug.Print "All is well"相同但是，请注意，没有End If。如果要跟随Then有多个命令，则必须使用End If，例如，

If 1 <> 2 Then
    Debug.Print "All is well"
    A = 3
End If

此处，If和End If之间的所有内容只会在1 <> 2时执行。这是If Len(c) <> 0 And Not ISIN(c, uniqueVal) Then _的情况。一旦UBound的错误得到解决，这将阻止您的代码运行。删除Then后面的下划线。

使用数组从多个工作表/ VBA中进行唯一复制

2 个答案: