Using an array for unique copy from multiple sheets / VBA

问题

I have been working on a macro that summarizes the data from multiple sheets in my workbook. In order to know which columns to use in my summary sheet I need to first extract all the unique values from the first column in my sheets.

The idea is that it will loop through the sheets and define a range, then it will loop through each cell in the range, check if the value of that cell is already in the array and if not copy and paste it and add it to the array.

Unfortunately I get an the error "Index outside of valid Area" for the line that is supposed to add the cell value to the array.

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

I took that specific code from the question https://superuser.com/questions/808798/excel-vba-adding-an-element-to-the-end-of-an-array .

Here is the entire code for reference.

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

回答1:

Per default, arrays in Excel VBA start with the index 0, not the index 1. You can test this by checking your arrays contents: your first string "Account by Type" should be on uniqueval(0) rather than on uniqueval(1).

Two ways to solve this:

add Option Base 1 to the top of your module or
change ReDim Preserve uniqueval(1 To UBound(uniqueval) + 1) to ReDim Preserve uniqueval(0 To UBound(uniqueval) + 1)

It's up to you which one you chose, but imo the latter is cleaner, since you don't have to fiddle with array options on module level.

As I see it, you're not actually using the arrays' contents yet. If you do later on, just loop For i = LBound(uniqueval) To UBound(uniqueval) - in which case it is irrelevant with what option you went.

回答2:

On the first loop uniqueVal has no Ubound. That's why it fails. So, you should first Redim it as Redim uniqueVal(1 To 1), then write to the Ubound and increase the size thereafter. That would always leave you with a blank element at the top which you can remove at the end. The better (because it runs faster) is to Dim uniqueVal to a possible max number, then set the current index with a counter, like i = i + 1, and do a Redim Preserve uniqueVal(i) at the end, thereby cutting off all unused elements.

The underscore at the end of a line of code means that the line is continued, logically, in the next line. For example,

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

This is the same as If 1 <> 2 Then Debug.Print "All is well" Observe, however, that there is no End If. If there were more than one command to follow the Then you must use End If, for example,

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

Here, everything between If and End If will only be executed if 1 <> 2. This is the case with If Len(c) <> 0 And Not ISIN(c, uniqueVal) Then _. Once the error of the UBound is cured this one will stop your code from running. Remove the underscore following the Then.

来源：https://stackoverflow.com/questions/45812894/using-an-array-for-unique-copy-from-multiple-sheets-vba

标签

arrays

vba

excel