对比两工作簿中人员，并合计数据

laterite

需求：一个代发表，一个增发表。对比两表，人员和卡号（C列数据）相同的，合计两个表中人员对应的金额到代发表，如果代发表没有增发表中有，则新增追求到代发表，如果代发表有增发表中没有，则保留代表表中人员。

比如熊二、张三、王五、陈六的金额（D列）合计到代发表，龙一、杨四新增到代发表，保留代发表中的熊大、李四

求如何实现上述需求，谢谢

liulang0808

https://club.excelhome.net/threa ... tml?_dsign=b73ad3d6
字典案例，可以参考下

ykcbf1100

参与一下，代码以附件为准。

1. Sub ykcbf()   '//2024.1.29
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("增发工资文件")
   
7.     arr = sh.UsedRange
   
8.     For i = 1 To UBound(arr)
   
9.         s = arr(i, 2) & "|" & arr(i, 3)
   
10.         If arr(i, 2) <> Empty Then
    
11.             If Not d.exists(s) Then
    
12.                 m = m + 1
    
13.                 d(s) = Array(m, arr(i, 2), arr(i, 3), arr(i, 4))
    
14.             Else
    
15.                 t = d(s)
    
16.                 t(3) = t(3) + arr(i, 4)
    
17.                 d(s) = t
    
18.             End If
    
19.         End If
    
20.     Next
    
21.     On Error Resume Next
    
22.     p = ThisWorkbook.Path
    
23.     f = p & "\代发工资文件.xls"
    
24.     Set wb = Workbooks.Open(f, 0)
    
25.     With wb.Sheets(1)
    
26.         arr = .UsedRange
    
27.         If arr(i, 2) <> Empty Then
    
28.             s = arr(i, 2) & "|" & arr(i, 3)
    
29.             If Not d.exists(s) Then
    
30.                 m = m + 1
    
31.                 d(s) = Array(m, arr(i, 2), arr(i, 3), arr(i, 4))
    
32.             Else
    
33.                 t = d(s)
    
34.                 t(s) = t(3) + arr(i, 4)
    
35.                 d(s) = t
    
36.             End If
    
37.         End If
    
38.         .UsedRange = ""
    
39.         With .[a1].Resize(d.Count, 4)
    
40.             .Value = Application.Rept(d.Items, 1)
    
41.             .Borders.LineStyle = 1
    
42.             .HorizontalAlignment = xlCenter
    
43.             .VerticalAlignment = xlCenter
    
44.         End With
    
45.     End With
    
46.     wb.Close 1
    
47.     Set d = Nothing
    
48.     Application.ScreenUpdating = True
    
49.     MsgBox "OK！"
    
50. End Sub
    

复制代码

ykcbf1100

原代码有误，现在更新一下。

cjc209

数据透视表就可以                  

limonet

关键字：union +group

feilanga

........................

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select * From [代发工资文件$A:D] Union ALl Select * From [Excel 12.0;HDR=NO;Database=" & ThisWorkbook.Path & "\增发工资文件 .xlsm].[增发工资文件$A:D]"
    StrSQL = "Select First(F1),First(F2),F3,Sum(F4) From (" & StrSQL & ") Group By F3"
    Range("A1").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

laterite

liulang0808 发表于 2024-1-29 12:45
https://club.excelhome.net/thread-1385473-1-1.html?_dsign=b73ad3d6
字典案例，可以参考下

多谢版主，我会好好研究的

laterite

ykcbf1100 发表于 2024-1-29 13:07
原代码有误，现在更新一下。

多谢草爷出手帮助，感谢