Question

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

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

表格来自不同的工作表。

表1的示例

表2的示例

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

我的代码结构

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表：

将二维VBA数组写入工作表

如果您有二维数组，则需要使用“调整大小”来调整大小   目的地范围到适当的大小。第一个维度是   行数和第二维是列数。该   下面的代码说明了将数组（..table2Arr ..）写入工作表   从细胞开始（..A2 ..）。

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

比较2个1-D动态阵列

1 个答案: