两个表之间匹配，并把未缴钱的提示出来！

jjip123

表一： ，想单击按钮就能实现，这个表的B列与表二： 此表的A列进行对比，1、把表二里有，表一里没有的数据所在行标记成黄色 2、把表二里有，表一里没有的数据分别按表二W、Y 列、L列的格式提示出来（提示格式如：四川绵阳公司/李玉宝/138；如Y列有相同名字就对这个名字汇总列出来。请各位大神帮我编个代码！谢谢各位！！

chaohuahch

为了测试的效果，再表格里面多增加了一行。

1. Sub fyExcelVBA()
   
2. Dim arr, brr, i%, j%, path$, str$, n%, str1$
   
3. Dim dic As Object, dic1 As Object, dic2 As Object
   
4. Application.DisplayAlerts = False
   
5. Application.ScreenUpdating = False
   
6. Set dic = CreateObject("scripting.dictionary")
   
7. Set dic1 = CreateObject("scripting.dictionary")
   
8. Set dic2 = CreateObject("scripting.dictionary")
   
9. path = ThisWorkbook.path & ""
   
10. str = "代收货款账单.xls"
    
11. With Workbooks.Open(path & str)
    
12.     arr = .ActiveSheet.Range("a1").CurrentRegion
    
13.     .Close 0
    
14. End With
    
15. brr = ActiveSheet.Range("a2").CurrentRegion
    
16. For i = 2 To UBound(brr)
    
17.      dic(brr(i, 2)) = ""
    
18. Next i
    
19. n = 0
    
20. For i = 2 To UBound(arr)
    
21.       If Not dic.exists(arr(i, 1)) Then
    
22.          If Not dic1.exists(arr(i, 1)) Then
    
23.              If Not dic2.exists(arr(i, 25)) Then
    
24.                  dic2(arr(i, 25)) = arr(i, 12)
    
25.                  dic1(arr(i, 1)) = arr(i, 23) & "/" & arr(i, 25) & "/"
    
26.              Else
    
27.                  dic2(arr(i, 25)) = dic2(arr(i, 25)) + arr(i, 12)
    
28.                  dic1(arr(i, 1)) = arr(i, 23) & "/" & arr(i, 25) & "/"
    
29.              End If
    
30.          End If
    
31.       End If
    
32. Next i
    
33. kk = dic2.items
    
34. With Workbooks.Open(path & str)
    
35.        .ActiveSheet.Cells.Interior.ColorIndex = 0
    
36. For i = 2 To UBound(arr)
    
37.     If dic1.exists(arr(i, 1)) Then
    
38.         Rows(i).Interior.Color = 65535
    
39.     End If
    
40. Next i
    
41. .Close 1
    
42. End With
    
43. For i = 0 To dic2.Count - 1
    
44.         str1 = str1 & Chr(10) & dic1.items()(i) & dic2.items()(i)
    
45. Next i
    
46. MsgBox str1
    
47. Set dic = Nothing: Set dic1 = Nothing: Set dic2 = Nothing
    
48. Application.DisplayAlerts = True
    
49. Application.ScreenUpdating = True
    
50. End Sub
    

复制代码

jjip123

chaohuahch 发表于 2018-8-25 22:22
为了测试的效果，再表格里面多增加了一行。

提示这个，但我代收货款账单这个表是放在这个位置的

chaohuahch

jjip123 发表于 2018-8-27 09:03
提示这个，但我代收货款账单这个表是放在这个位置的

path = ThisWorkbook.path & "\" 这句代码，可能复制的时候，有点问题，这给双引号里面，应该有以给斜杆。

jiminyanyan

chaohuahch 发表于 2018-8-27 18:28
path = ThisWorkbook.path & "\" 这句代码，可能复制的时候，有点问题，这给双引号里面，应该有以给斜杆 ...

论坛会吃 斜杆