Vba 基于唯一ID将两个大表合并为一个表

首先，我对VBA知之甚少，也没有为我想做的事情编写代码，因为我甚至不知道从哪里开始

我现在有两张桌子。表1包含48000行数据和两列，每个ID包含一个唯一标识符和一个现金金额。表2包含50000行数据和两列，每个ID包含一个唯一标识符和一个现金金额。ID号对其自己的表是唯一的，因此在另一个表中经常重复ID。这样做的目的是按ID号组合这两个表，并显示每个ID号的总现金金额

我的第一次尝试是使用SUMIF函数从两个表中获取总计。虽然这对第一个ID有效，但当我试图将公式复制到其他单元格时，我的笔记本电脑完全崩溃，迫使重新启动

我的第二次尝试涉及使用数据透视表向导来组合这两个范围。但是，我发现数据透视表无法处理这么多的唯一值。（基于出现的弹出窗口）

我的第三次尝试成功了，但我发现时间很长，我希望有更好的方法。我将我的表分成两个范围，大约20000行（因此现在有4个表）。然后，我使用数据透视表向导一次将这两个数据组合在一起。首先是表1和表3，然后是表2和表4。然后我不得不再次拆分结果列表，因为数据透视表无法处理它，于是重复了这个过程。这种方法的问题是，我觉得由于所有的分裂，肯定有可能遗漏或重复值

在这三次尝试中，我的电脑反复出现问题，需要重新启动

我不在乎VBA解决方案是否需要一段时间才能运行，只要它有效

我试过看其他的例子，但有些我不知道如何将它们应用到我的情况中，还有一些似乎没有处理足够大的文件来体验我所面临的一些问题

---

谢谢，如果您需要任何澄清，请告诉我。

如果您想要一个不使用透视表的VBA解决方案，您可以尝试创建一个dictionary对象，并使用ID作为键，使用现金值作为值。这样地。您需要首先添加对Microsoft脚本运行时的引用

Sub CreateEmployeeSum()
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim table1 As Worksheet, _
        table2 As Worksheet, finalTable As Worksheet
    'wasn't sure if you were using sheets of data
    'or actual tables - if they are actual tables,
    'you can loop through those in a similar way, look up
    'on other stackoverflow problems how


    Set table1 = wb.Sheets("Sheet1") 'first sheet of info
    Set table2 = wb.Sheets("Sheet2") 'second sheet of info
    Set finalTable = wb.Sheets("Sheet3") 'destination sheet


    'get the last row of both tables
    Dim lastRowT1 As Long, lastRowT2 As Long
    lastRowT1 = table1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lastRowT2 = table2.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

    'write the info to arrays so faster to loop through
    Dim t1Array As Variant, t2Array As Variant
    t1Array = table1.Range("A1:B" & lastRowT2).Value
    t2Array = table2.Range("A1:B" & lastRowT2).Value

    'create a dictionary that maps IDs to cash value
    Dim idToCashDict As Dictionary
    Set idToCashDict = New Dictionary

    'first loop through info from first sheet
    Dim i As Long
    For i = 1 To UBound(t1Array)
        Dim idNum As String, cashVal As Double
        idNum = CStr(t1Array(i, 1))
        cashVal = CDbl(t1Array(i, 2))
        If idToCashDict.Exists(idNum) Then
            cashVal = cashVal + idToCashDict.Item(idNum)
            idToCashDict.Remove idNum
            idToCashDict.Add idNum, cashVal
        Else
            idToCashDict.Add idNum, cashVal
        End If

    Next i

    'then through second sheet, adding to cash value of
    'ids that have been seen before
    For i = 1 To UBound(t2Array)
        Dim idNum2 As String, cashVal2 As Double
        idNum2 = CStr(t2Array(i, 1))
        cashVal2 = CDbl(t2Array(i, 2))
        If idToCashDict.Exists(idNum2) Then
            cashVal2 = cashVal2 + idToCashDict.Item(idNum2)
            idToCashDict.Remove idNum2
            idToCashDict.Add idNum2, cashVal2
        Else
            idToCashDict.Add idNum2, cashVal2
        End If

    Next i


    'then write the entries from the dictionary to the
    'destination sheet
    Dim finalVal As Double, finalID As String
    i = 1
    For Each finalID In idToCashDict.Keys
        finalVal = idToCashDict.Item(finalID)
        finalTable.Range("A" & i).Value = finalID
        finalTable.Range("B" & i).Value = finalVal
        i = i + 1
    Next finalID


End Sub

---

如果使用实际的表，请参见答案，例如，以便以类似的方式在行中循环。

这里尝试获得一个排序和组合的表。我在这里采用的一般策略是：复制现有表，并使用它们添加值，删除重复值，然后对第3页上的第三个组合表执行相同的操作。将以下代码附加到命令按钮

Application.ScreenUpdating = False
Dim i As Long, x As Long, n As Long, j As Long
Dim cashtotal As Integer

lastrow1 = Sheet1.Range("A1048575").End(xlUp).Row
astrow2 = Sheet2.Range("A1048575").End(xlUp).Row
cashtotal = 0
x = 1

'''''Routine to make a copy of the existing data.
For i = 1 To lastrow1
    Sheet1.Cells(i, 4) = Sheet1.Cells(i, 1)
    Sheet1.Cells(i, 5) = Sheet1.Cells(i, 2)
Next

'''''On Sheet1- Routine to remove repetitive values
For i = 2 To lastrow1
    If Sheet1.Cells(i, 4) = "" Then GoTo 10
      x = x + 1
      cashtotal = Sheet1.Cells(i, 5)
      Sheet1.Cells(x, 7) = Sheet1.Cells(i, 4)
      Sheet1.Cells(x, 8) = Sheet1.Cells(i, 5)

        For j = i + 1 To lastrow1
           If Sheet1.Cells(j, 4) = Sheet1.Cells(i, 4) Then
             cashtotal = cashtotal + Sheet1.Cells(j, 5)
             Sheet1.Cells(x, 8) = cashtotal
             Sheet1.Cells(j, 4).ClearContents
             Sheet1.Cells(j, 5).ClearContents
           End If
        Next
10
Next
x = 1

'''''On Sheet2 the following routine makes a copy of the existing data
For i = 1 To lastrow2
    Sheet2.Cells(i, 4) = Sheet2.Cells(i, 1)
    Sheet2.Cells(i, 5) = Sheet2.Cells(i, 2)
Next

'''''On sheet2 -  Routine to remove repetitive values
For i = 2 To lastrow2
    If Sheet2.Cells(i, 4) = "" Then GoTo 20
       x = x + 1
       cashtotal = Sheet2.Cells(i, 5)
       Sheet2.Cells(x, 7) = Sheet2.Cells(i, 4)
       Sheet2.Cells(x, 8) = Sheet2.Cells(i, 5)
          For j = i + 1 To lastrow2
            If Sheet2.Cells(j, 4) = Sheet2.Cells(i, 4) Then
              cashtotal = cashtotal + Sheet2.Cells(j, 5)
              Sheet2.Cells(x, 8) = cashtotal
              Sheet2.Cells(j, 4).ClearContents
              Sheet2.Cells(j, 5).ClearContents
            End If
          Next
20
Next
x = 1

'''Transfer modified tables on sheet1 and sheet2 to sheet3 in a combined table
lastrow4 = Sheet1.Range("G1048575").End(xlUp).Row

For i = 1 To lastrow4
    Sheet3.Cells(i, 1) = Sheet1.Cells(i, 7)
    Sheet3.Cells(i, 2) = Sheet1.Cells(i, 8)
Next

lastrow5 = Sheet2.Range("G1048575").End(xlUp).Row
lastrow6 = Sheet3.Range("A1048575").End(xlUp).Row

For i = 2 To lastrow5
    Sheet3.Cells(lastrow6 + i - 1, 1) = Sheet2.Cells(i, 7)
    Sheet3.Cells(lastrow6 + i - 1, 2) = Sheet2.Cells(i, 8)
Next

'''''''Routine to make a copy of the existing table
lastrow7 = Sheet3.Range("A1048575").End(xlUp).Row

For i = 1 To lastrow7
    Sheet3.Cells(i, 4) = Sheet3.Cells(i, 1)
    Sheet3.Cells(i, 5) = Sheet3.Cells(i, 2)
Next

'''''''' Routine to remove repetitive values
For i = 2 To lastrow7
    If Sheet3.Cells(i, 4) = "" Then GoTo 30
      x = x + 1
      cashtotal = Sheet3.Cells(i, 5)
      Sheet3.Cells(x, 7) = Sheet3.Cells(i, 4)
      Sheet3.Cells(x, 8) = Sheet3.Cells(i, 5)
         For j = i + 1 To lastrow7
            If Sheet3.Cells(j, 4) = Sheet3.Cells(i, 4) Then
               cashtotal = cashtotal + Sheet3.Cells(j, 5)
               Sheet3.Cells(x, 8) = cashtotal

               Sheet3.Cells(j, 4).ClearContents
               Sheet3.Cells(j, 5).ClearContents
            End If
        Next
30
Next
Application.ScreenUpdating = True

---

我建议通过ADO连接连接到工作表，并使用SQL语句连接两个表

添加对Microsoft ActiveX数据对象库的引用（工具->引用…）-使用通常为6.1的最新版本

将模块插入VBA项目并粘贴以下代码：

Sub JoinTables()

Dim connectionString As String
connectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=""" & ActiveWorkbook.FullName & """;" & _
    "Extended Properties=""Excel 12.0;HDR=Yes"""

'The SQL statement that shapes the resulting data
Dim sql As String
sql = _
    "SELECT t1.ID, t1.Value + IIF(t2.Value IS NULL, 0, t2.Value) AS FinalSum " & _
    "FROM [Sheet1$] AS t1 " & _
    "LEFT JOIN [Sheet2$] AS t2 ON t1.ID = t2.ID " & _
    "UNION SELECT t2.ID, t2.Value " & _
    "FROM [Sheet2$] AS t2 " & _
    "LEFT JOIN [Sheet1$] AS t1 ON t2.ID = t1.ID " & _
    "WHERE t1.ID IS NULL"

Dim rs As New ADODB.Recordset
'All the fun happens here
rs.Open sql, connectionString

'Paste the resulting records into the third sheet of the active workbook
ActiveWorkbook.Sheets(3).Range("A2").CopyFromRecordset rs

Set rs = Nothing

End Sub

注:

• 当前，记录集正在从当前（Excel）工作簿读取数据。如果数据来自数据库，那么直接连接到数据库并针对数据库发出SQL语句可能更简单、更高效
• 代码假定每个工作表的第一行包含列标签，例如

  ID

  和

  Value

  。如果不是这种情况，请在

  连接字符串

  的第三行指定

  HDR=No

  （而不是

  HDR=Yes

  ），字段将自动分配名称，从

  F1

  、

  F2

  开始
• 结果将粘贴到活动工作簿的第三页中。这可能合适，也可能不合适
• 您没有指定数据的排序方式，但在SQL语句中添加了一个

  orderby

  子句，这就足够简单了

---

SQL语句的解释

我们正在比较两个表。对于给定的ID，可能有三种可能性：
1.ID显示在两个表中，
2.它仅出现在第一个表中，或
3.它仅出现在第二个表中

我们还假设每个表中的ID都是唯一的

语句的前半部分（直到

UNION

）处理1和2

SELECT t1.ID, t1.Value + IIF(t2.Value IS NULL, 0, t2.Value) AS FinalSum 
FROM [Sheet1$] AS t1
LEFT JOIN [Sheet2$] AS t2 ON t1.ID = t2.ID

可以这样描述：

从[Sheet1$]中第一个表中的记录开始，作为t1

将第二个表中的每条记录与第一个表中的相应记录进行匹配，基于ID-

左连接[Sheet2$]作为t1.ID=t2.ID上的t2

包括第一个表中的所有记录，并且仅包括第二个表中的匹配记录-在
左联接中的
左

返回两列：第一个表的ID，以及第一个表和第二个表的值的组合-
SELECT…

如果第二个表中没有匹配的记录，则该值将为NULL（与零不同）。尝试向NULL添加一个数字将返回NULL，这不是我们想要的。所以我们必须写出这个公式-
t1.Value+IIF（t2.Value为NULL，0，t2.Value）
：


如果第二个表中的值为空，则添加0

否则，添加第二个表中的值


语句的后半部分处理仅出现在第二个表中的ID：

UNION 
SELECT t2.ID, t2.Value
FROM [Sheet2$] AS t2
LEFT JOIN [Sheet1$] AS t1 ON t2.ID = t1.ID
WHERE t1.ID IS NULL

在第一组结果的顶部追加第二组结果-
UNION

从第二个表中的记录开始，从[Sheet2$]中的
作为t2

将第一个表中的记录与第二个表中的记录进行匹配（注意，这与第一个h相反