使用数组从多张纸/VBA中进行唯一复制 [英] 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

我从问题 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

推荐答案

默认情况下，Excel VBA中的数组以索引 0 而不是索引 1 开头.您可以通过检查数组的内容进行测试:第一个字符串按类型计费" 应该在 uniqueval(0)上，而不是在 uniqueval(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).

两种解决方法:

1. 在模块顶部或

将 ReDim保留uniqueval(1到UBound(唯一性)+ 1)更改为 ReDim保留uniqueval(0到UBound(唯一性)+ 1)

由您决定选择哪一个，但是imo则更干净，因为您不必在模块级别上摆弄数组选项.

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.

正如我所看到的，您实际上还没有使用数组的内容.如果以后再做，只需将 For i = LBound(uniqueval)循环到UBound(uniqueval)-在这种情况下，与您选择的选项无关.

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.

这篇关于使用数组从多张纸/VBA中进行唯一复制的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！