两列不完全一致数据对比，不同自动插入空白行

manzoneut

要将abc三列的数据与efg三列数据按照项目号对齐再对金额和科目进行比对。
a，e两列数据已经按升序排列，A,E两列中的项目名称会重复，并且重复数量不一定相同，A列中的项目E列不一定有，反过来E列中的项目A也不一定有。
如何将a，e两列内容逐行进行对比，若内容不同，则在单元格不同的列下加入空白单元格，同时保证下面行A,E两列中的项目相同。效果如第二张图。方便下一步金额和科目的对比。实际比对数据行和列的内容都比较多，麻烦大神帮忙指导，感激不尽。
工作簿1.rar (8.24 KB, 下载次数: 76)

2017-7-6 00:51 上传

点击文件名下载附件

qingc0221

Mark一下..

manzoneut

用函数或vba都可以，有高手帮帮忙吗

manzoneut

求老司机帮助

zzzxxxmmm

帮顶。。。。。。大师出手！！！

lsdongjh

自己看代码：

1. Sub Test()
   
2.     Dim arr As Variant, lngR As Long, lngC As Long
   
3.     Dim objDicKeys As Object, objDicA As Object, objDicB As Object, arrKeys As Variant
   
4.     Dim strKey  As String, strRow_1() As String, strRow_2() As String, strValue() As String
   
5.     Dim arrResult As Variant
   
6.     Dim lngRowCount As Long, lngRows As Long
   
7.     Dim lngRow_Start_ID As Long
   
8.    
   
9.     arr = Sheet1.Range("A1").CurrentRegion
   
10.    
    
11.     Set objDicKeys = CreateObject("Scripting.Dictionary")
    
12.     Set objDicA = CreateObject("Scripting.Dictionary")
    
13.     Set objDicB = CreateObject("Scripting.Dictionary")
    
14.    
    
15.     ReDim arrResult(1 To 7, 1 To 1)
    
16.    
    
17.     For lngR = 3 To UBound(arr)
    
18.         If arr(lngR, 1) <> "" Then
    
19.             objDicKeys(arr(lngR, 1)) = ""
    
20.             objDicA(arr(lngR, 1)) = objDicA(arr(lngR, 1)) & "|" & arr(lngR, 2) & "@" & arr(lngR, 3)
    
21.         End If
    
22.         
    
23.         If arr(lngR, 5) <> "" Then
    
24.             objDicKeys(arr(lngR, 5)) = ""
    
25.             objDicB(arr(lngR, 5)) = objDicB(arr(lngR, 5)) & "|" & arr(lngR, 6) & "@" & arr(lngR, 7)
    
26.         End If
    
27.     Next
    
28.    
    
29.     arrKeys = objDicKeys.keys
    
30.     lngRow_Start_ID = 1
    
31.     lngRowCount = 0
    
32.     For lngR = LBound(arrKeys) To UBound(arrKeys)
    
33.         strKey = arrKeys(lngR)
    
34.         strRow_1 = Split(objDicA(strKey), "|")
    
35.         strRow_2 = Split(objDicB(strKey), "|")
    
36.         
    
37.         lngRows = IIf(UBound(strRow_1) > UBound(strRow_2), UBound(strRow_1), UBound(strRow_2))
    
38.         
    
39.         lngRowCount = lngRowCount + lngRows
    
40.         
    
41.         ReDim Preserve arrResult(1 To 7, 1 To lngRowCount)
    
42.         
    
43.         For lngC = 1 To UBound(strRow_1)
    
44.             strValue = Split(strRow_1(lngC), "@")
    
45.             arrResult(1, lngRow_Start_ID + lngC - 1) = strKey
    
46.             arrResult(2, lngRow_Start_ID + lngC - 1) = strValue(0)
    
47.             arrResult(3, lngRow_Start_ID + lngC - 1) = strValue(1)
    
48.         Next
    
49.         For lngC = 1 To UBound(strRow_2)
    
50.             strValue = Split(strRow_2(lngC), "@")
    
51.             arrResult(5, lngRow_Start_ID + lngC - 1) = strKey
    
52.             arrResult(6, lngRow_Start_ID + lngC - 1) = strValue(0)
    
53.             arrResult(7, lngRow_Start_ID + lngC - 1) = strValue(1)
    
54.         Next
    
55.         
    
56.         lngRow_Start_ID = lngRowCount + 1
    
57.     Next
    
58.    
    
59.     Sheet1.Range("R3").Resize(lngRowCount, 7) = Application.WorksheetFunction.Transpose(arrResult)
    
60. End Sub

复制代码

manzoneut

lsdongjh 发表于 2017-7-6 12:44
自己看代码：

感谢大师帮忙，运行后出现问题，可以继续看看吗？
运行时错误“13” 类型不匹配
第17行 For lngR = 3 To UBound(arr)

lsdongjh

manzoneut 发表于 2017-7-6 15:20
感谢大师帮忙，运行后出现问题，可以继续看看吗？
运行时错误“13” 类型不匹配
第17行 For lngR = 3 T ...

代码中没有考虑 很多细节，如：没有数据。用你上传的示例测试正常，请上传出错的文件

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, crr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     For j = 1 To 5 Step 4
   
8.       r = .Cells(.Rows.Count, j).End(xlUp).Row
   
9.       arr = .Cells(3, j).Resize(r - 2, 3)
   
10.       For i = 1 To UBound(arr)
    
11.         If Not d.exists(arr(i, 1)) Then
    
12.           Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
13.         End If
    
14.         If Not d(arr(i, 1)).exists(j) Then
    
15.           m = 1
    
16.           ReDim brr(1 To 3, 1 To m)
    
17.         Else
    
18.           brr = d(arr(i, 1))(j)
    
19.           m = UBound(brr, 2) + 1
    
20.           ReDim Preserve brr(1 To 3, 1 To m)
    
21.         End If
    
22.         For k = 1 To 3
    
23.           brr(k, m) = arr(i, k)
    
24.         Next
    
25.         d(arr(i, 1))(j) = brr
    
26.       Next
    
27.     Next
    
28.     .Range("j3:p" & .Rows.Count).Clear
    
29.     m = 3
    
30.     For Each aa In d.keys
    
31.       r = .Columns("j:p").Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    
32.       For Each bb In d(aa).keys
    
33.         brr = d(aa)(bb)
    
34.         ReDim crr(1 To UBound(brr, 2), 1 To UBound(brr))
    
35.         For i = 1 To UBound(brr)
    
36.           For j = 1 To UBound(brr, 2)
    
37.             crr(j, i) = brr(i, j)
    
38.           Next
    
39.         Next
    
40.         n = bb + 9
    
41.         .Cells(r + 1, n).Resize(UBound(crr), UBound(crr, 2)) = crr
    
42.       Next
    
43.     Next
    
44.   End With
    
45. End Sub
    

复制代码

chxw68

详见附件。