根据唯一ID将两张大表合二为一

Question

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

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

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

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

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

在所有这三个尝试中，我的计算机反复出现问题并需要重新启动。

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

我尝试查看其他示例，但有些示例我无法弄清楚如何将它们应用于我的情况，而其他示例似乎没有处理足够大的文件来体验我面临的一些问题。

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

Answer 1

最后，我使用数据透视表向导将范围以 10,000 个为单位进行组合。

感谢您的帮助。

Answer 2

我建议通过 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) 工作簿中读取数据。如果数据来自数据库，modify the connection string 直接连接数据库并针对数据库发出 SQL 语句可能更简单、更高效。
• 代码假定每个工作表的第一行包含列标签，例如ID 和 Value。如果不是这种情况，请在connectionString 的第三行指定HDR=No（而不是HDR=Yes），这些字段将自动分配名称以F1、F2 等开头。
• 结果将粘贴到活动工作簿的第三张工作表中。这可能合适，也可能不合适。
• 您无需指定数据的排序方式，但只要在 SQL 语句中添加 ORDER BY 子句就足够简单了。

---

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

可以这样描述：

从第一个表中的记录开始——FROM [Sheet1$] AS t1

根据 ID — LEFT JOIN [Sheet2$] AS t2 ON t1.ID = t2.ID 将第二个表中的每条记录与第一个表中的相应记录匹配

包含第一个表中的所有记录，并且仅包含第二个表中的匹配记录 — LEFT JOIN 中的 LEFT

返回两列：来自第一个表的 ID，以及来自第一个和第二个表的值的组合 — SELECT ...

如果第二个表中没有匹配的记录，则该值将为 NULL（不等于零）。尝试将数字添加到 NULL 将返回 NULL，这不是我们想要的。所以我们必须写出这个公式——t1.Value + IIF(t2.Value IS 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

从 second 表中的记录开始 — FROM [Sheet2$] AS t2

将 first 表中的记录与 second 表中的记录进行匹配（注意这与查询的前半部分相反）-LEFT JOIN [Sheet1$] AS t1 ON t2.ID = t1.ID

我们只想要第一个表中没有 ID 的记录 — WHERE t1.ID IS NULL

Answer 3

如果您想要一个不使用数据透视表的 VBA 解决方案，您可以尝试创建一个字典对象并使用 ID 作为键和现金值作为值。像这样。您需要先添加对 Microsoft Scripting Runtime 的引用。

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

如果您使用实际的表格，请参阅here 等答案，以便以类似方式遍历行。

Answer 4

这是一个获得排序和组合表的尝试。我在这里采用的一般策略是：复制现有表并使用它们来添加值、删除重复值，并对工作表 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