恳请高手师傅们帮忙解决这个对比填入的难题

qiongmei6

我想求得一个代码，就是“社保账户”内a列的名字与“汇总”表格c列的名字如果相同，则“社保账户”的b列则出现“汇总”表格的d列，“社保账户”的c列则出现“汇总”表格的f列，如果“社保账户”的a列有有“汇总”表格c列没有的名字，则“社保账户”a列新增到“汇总”的c列，“社保账户”的b列新增到“汇总”的d列，“社保账户”的c列新增到“汇总”表格的f列“，之前我也发过类似的问题，但是因为当时没想到，只是发一列填入，现在要两列填入就不会修改了，因此再次将这个问题发上来，恳请大神帮忙，因为想让大神们更能理解我的意思，我在汇总”在k列做个表格就是代码执行后希望在a3看到的结果，再次谢谢大神们的帮忙

shiruiqiang

直接字典，有的匹配，没有的新增

582766

一串文字看得我头昏

ahnyt

有些没有看懂，加我的Q吧，具体说说

feilanga

1. Sub t()
   
2.     arr = Sheet2.Range("A1:C" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row) '数据源装入数组
   
3.     Dim dic As Object
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     For i = 3 To UBound(arr)
   
6.         Key = arr(i, 1)
   
7.         dic(Key) = i
   
8.     Next
   
9.     crr = Sheet1.Range("A1:H" & Sheet1.Cells(Rows.Count, "A").End(xlUp).Row)
   
10.     For i = 3 To UBound(crr)
    
11.         Key = crr(i, 3)
    
12.         If dic.Exists(Key) Then
    
13.             行号 = dic(Key)
    
14.             crr(i, 4) = arr(行号, 2)
    
15.             crr(i, 6) = arr(行号, 3)
    
16.             dic.Remove Key
    
17.         End If
    
18.     Next
    
19.     Sheet1.Range("A1:H" & Sheet1.Cells(Rows.Count, "A").End(xlUp).Row) = crr
    
20.     keys = dic.keys
    
21.     items = dic.items
    
22.     If dic.Count > 0 Then
    
23.         ReDim brr(1 To dic.Count, 1 To 8)
    
24.         For m = 0 To dic.Count - 1
    
25.             行号 = items(m)
    
26.             k = k + 1
    
27.             brr(k, 1) = arr(行号, 1)
    
28.             brr(k, 2) = arr(行号, 2)
    
29.             brr(k, 4) = arr(行号, 3)
    
30.         Next
    
31.     End If
    
32.     n = Sheet1.Cells(Rows.Count, 3).End(xlUp).Row + 1
    
33.     Sheet1.Range("C" & n).Resize(k, 6) = brr
    
34. End Sub

复制代码

lcluck2002

仅供参考
恳请高手师傅们帮忙解决这个对比填入的难题.zip