vba - 比较 2 个一维动态数组

Question

我有两张 table 。第一个表包含部门名称和人数，另一个表包含部门名称和一些其他信息。我正在尝试根据部门名称将第一个表中的人数复制到第二个表中。

但是，表的大小与第二个表不相等，部门名称可以出现多次，甚至根本不出现。

表格来自不同的工作表。

表 1 示例

表 2 示例

我已经使用动态数组成功从列中获取数据并在子程序之间传递，但在匹配时复制值时无法进行比较。

我的代码结构

Sub getTable1()

    Dim dept, getNum As Variant
    Dim i,x As Long
    x = 0

    ReDim dept(1 To 1)
    ReDim getNum(1 To 1)

    With ThisWorkbook.Sheets("Table1")
            For i= 1 To .Cells(Rows.Count, "A").End(xlUp).Row
            x = x + 1
            ReDim Preserve dept(1 To x)
            ReDim Preserve getNum(1 To x)

            dept(x) = .Cells(i, "A").Value
            getNum(x) = .Cells(i, "B").Value

            Next x
    End With

    For i = 1 to x
        Call passValue(dept(i), getNum(i))
    Next

End Sub

Sub passValue(ByVal dept, getNum As Variant)

    Dim target As Variant
    ReDim target(1 To 1)

    Dim i, cnt, rowCnt As Long
    cnt = 0

    With ThisWorkbook.Sheets("Table2")
    For i = 2 To .Cells(Rows.Count, "D").End(xlUp).Row

                cnt = cnt + 1
                ReDim Preserve target(1 To cnt)
                target(cnt) = .Cells(i, "D").Value
    Next i
    End With

    For i = 1 To cnt
        If target(i) = dept Then ' If match print result
            With ThisWorkbook.Sheets("Table2")
                For rowCnt = 2 To .Cells(Rows.Count, "D").End(xlUp).Row
                .Cells(rowCnt, "E").Value = getNum ' Only print the last result
                Next
            End With
        End If
    Next
End Sub

Answer 1

这是我所描述的示例，您可能需要一些错误处理，以防某个部门出现在工作表 Table2 中但不在 Table1 中:

Public Sub getTable1()

  Dim wb As Workbook
  Dim ws1 As Worksheet
  Dim ws2 As Worksheet

  Set wb = ThisWorkbook
  Set ws1 = wb.Worksheets("Table1")
  Set ws2 = wb.Worksheets("Table2")

  Dim lastRowT1 As Long
  lastRowT1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row 'find last row in column A of first sheet

  Dim lastRowT2 As Long
  lastRowT2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row 'find last row in column A of second sheet

  Dim table1Arr()
  table1Arr = ws1.Range("A2:B" & lastRowT1).Value '1 to 4, 1 to 2  'read the range from A2:B to last used row in A e.g. A2:B6 into array creating a 2D array that starts at index 1. The table is now held in the array.

  Dim table2Arr()
  table2Arr = ws2.Range("A2:B" & lastRowT2).Value '1 to 3, 1 to 2 'read used range containing table 2 into an array.

  Dim table1Dict As New Scripting.Dictionary 'required reference to MS Scripting Runtime

  Dim i As Long

  For i = LBound(table1Arr, 1) To UBound(table1Arr, 1) 'loop the first dimension of array 1 i.e. the depts.

      If table1Dict.Exists(table1Arr(i, 1)) Then

        table1Dict(table1Arr(i, 1)) = table1Dict(table1Arr(i, 1)) + table1Arr(i, 2)   'if dept exists as a key in the dict then add the number of people from array 1 (i.e. from table 1) to the existing value. This handles potentially repeating depts in table1.

    Else

       table1Dict.Add table1Arr(i, 1), table1Arr(i, 2) 'if dept not already in dict, add the dept as a key to the dict and the number of people as the value.

    End If

 Next i

 For i = LBound(table2Arr, 1) To UBound(table2Arr, 1)  'next loop your table 2 array depts

     table2Arr(i, 2) = table1Dict(table2Arr(i, 1))  'as department names are spelt the same across both tables you can use the table2 dept names as the key to retrieve the dictionary values for that dept in the dictionary i.e. from table1. Then simply assign that to the Others column i.e.  table2Arr(i, 2) 

 Next i

End Sub

参见Chip Pearson关于使用数组的文章。从那篇文章中，您可以看到如何将第二个数组写回 Table2 工作表:

Writing A Two Dimensional VBA Array To The Worksheet

If you have a 2 dimensional array, you need to use Resize to resize the destination range to the proper size. The first dimension is the number of rows and the second dimension is the number of columns. The code below illustrates writing an array (..table2Arr..) out to the worksheet starting at cell (..A2..).

Dim Destination As Range
Set Destination = ws2.Range("A2")
Destination.Resize(UBound(table2Arr, 1), UBound(table2Arr, 2)).Value = table2Arr