[特殊字典查询]根据数据源表中数据，在查询表对应行利用字典查询并插入行合并单元格

lele400024

1016373263 发表于 2020-10-11 00:21
考虑周全后代码量不会很少

之前一直不明白字典嵌套原理，谢谢老师您的指导，太感谢了。

lele400024

1016373263 发表于 2020-10-11 00:21
考虑周全后代码量不会很少

老师，您好，照你的方法实施具体案例的时候，第一个重复字段合并后就一直出现如图这个问题，由于数据隐私的问题，不方便把数据传上来，能加你个QQ吗，谢谢

lele400024

1016373263 发表于 2020-10-11 00:21
考虑周全后代码量不会很少

老师，您好，实际数据运行过程中，存在一个问题，当查询表第二列名称中，劳务数据表不存在一一对应的名称，代码就会报错，不知道怎么修改这个代码呢。例如把下图中Z3改成Z2,就直接报错了。

lele400024

1016373263 发表于 2020-10-11 00:21
考虑周全后代码量不会很少

1. Private Sub CommandButton1_Click()
   
2. Application.ScreenUpdating = False
   
3. Dim d As Object, sht As Worksheet, arr, file As String, n%, k%
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set sht = Worksheets("查询表")
   
6. file = Dir(ThisWorkbook.Path & "\*.xlsx")
   
7.     Do While file <> ""
   
8.         If file <> ThisWorkbook.Name Then
   
9.             Workbooks.Open ThisWorkbook.Path & "" & file
   
10.             n = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
    
11.             arr = ActiveWorkbook.Worksheets(1).Range("b2:d" & n)
    
12.                 For i = 1 To UBound(arr)
    
13.                     If Not d.exists(arr(i, 1)) Then
    
14.                         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
15.                     End If
    
16.                     d(arr(i, 1))(arr(i, 2)) = arr(i, 3)
    
17.                 Next i
    
18.             ActiveWorkbook.Close False
    
19.         End If
    
20.         file = Dir
    
21.     Loop
    
22. 'v = 2
    
23. 'k = d.Count - 1
    
24. r = sht.[c65536].End(xlUp).Row
    
25.     For j = 0 To r - 1
    
26.       If d.exists(sht.Cells(j + 2, 2).Value) Then
    
27.         If d(sht.Cells(j + 2, 2).Value).Count = 1 Then
    
28.             sht.Cells(j + 2, 6) = d(sht.Cells(j + 2, 2).Value).keys
    
29.             sht.Cells(j + 2, 7) = d(sht.Cells(j + 2, 2).Value).items
    
30.             'v = v + 1
    
31.         Else
    
32.             sht.Rows(j + 2 + 1).EntireRow.Resize(d(sht.Cells(j + 2, 2).Value).Count - 1).Insert
    
33.             sht.Cells(j + 2, 6).Resize(d(sht.Cells(j + 2, 2).Value).Count, 1) = Application.Transpose(d(sht.Cells(j + 2, 2).Value).keys)
    
34.             sht.Cells(j + 2, 7).Resize(d(sht.Cells(j + 2, 2).Value).Count, 1) = Application.Transpose(d(sht.Cells(j + 2, 2).Value).items)
    
35.                 For Z = 2 To 5
    
36.                     sht.Cells(j + 2, Z).Resize(d(sht.Cells(j + 2, 2).Value).Count, 1).MergeCells = True
    
37.                 Next Z
    
38.             'v = v + d(sht.Cells(j + 2, 2).Value).Count
    
39.         End If
    
40.       End If
    
41.     Next
    
42. Application.ScreenUpdating = True
    
43. End Sub
    

复制代码

根据实际数据情况，根据老师您提供的代码，进行了修改，再次感谢。

1016373263

lele400024 发表于 2020-10-13 12:23
老师，您好，照你的方法实施具体案例的时候，第一个重复字段合并后就一直出现如图这个问题，由于数据隐私 ...

1016373263

1016373263

lele400024 发表于 2020-10-13 12:37
老师，您好，实际数据运行过程中，存在一个问题，当查询表第二列名称中，劳务数据表不存在一一对应的名称 ...

字典中没有，当然出错，需处理下，on error resume next

1016373263

1016373263 发表于 2020-10-13 15:35
字典中没有，当然出错，需处理下，on error resume next

模拟数据过少，特殊情况未列出，所以未考虑

lele400024

1016373263 发表于 2020-10-13 15:38
模拟数据过少，特殊情况未列出，所以未考虑

1. Private Sub CommandButton1_Click()
   
2. Application.ScreenUpdating = False
   
3. Dim d As Object, d1 As Object, d2 As Object, d3 As Object, sht As Worksheet, arr, file As String, n%, k%
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set d1 = CreateObject("scripting.dictionary")
   
6. Set d2 = CreateObject("scripting.dictionary")
   
7. Set d3 = CreateObject("scripting.dictionary")
   
8. Set sht = Worksheets("查询表")
   
9. file = Dir(ThisWorkbook.Path & "\*.xlsx")
   
10.     Do While file <> ""
    
11.         If file <> ThisWorkbook.Name Then
    
12.             Workbooks.Open ThisWorkbook.Path & "" & file
    
13.             n = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 2).End(xlUp).Row
    
14.             arr = ActiveWorkbook.Worksheets(1).Range("b2:g" & n)
    
15.                 For i = 1 To UBound(arr)
    
16.                     If Not d.exists(arr(i, 1)) Then
    
17.                         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
18.                         Set d1(arr(i, 1)) = CreateObject("scripting.dictionary")
    
19.                         Set d2(arr(i, 1)) = CreateObject("scripting.dictionary")
    
20.                         Set d3(arr(i, 1)) = CreateObject("scripting.dictionary")
    
21.                     End If
    
22.                     d(arr(i, 1))(arr(i, 2)) = arr(i, 3)
    
23.                     d1(arr(i, 1))(arr(i, 2)) = arr(i, 4)
    
24.                     d2(arr(i, 1))(arr(i, 2)) = arr(i, 5)
    
25.                     d3(arr(i, 1))(arr(i, 2)) = arr(i, 6)
    
26.                     
    
27.                 Next i
    
28.             ActiveWorkbook.Close False
    
29.         End If
    
30.         file = Dir
    
31.     Loop
    
32. 'v = 2
    
33. 'k = d.Count - 1
    
34. r = sht.[c65536].End(xlUp).Row
    
35.     For j = 0 To r - 1
    
36.       If d.exists(sht.Cells(j + 2, 2).Value) Then
    
37.         If d(sht.Cells(j + 2, 2).Value).Count = 1 Then
    
38.             sht.Cells(j + 2, 6) = d(sht.Cells(j + 2, 2).Value).keys
    
39.             sht.Cells(j + 2, 7) = d(sht.Cells(j + 2, 2).Value).items
    
40.             sht.Cells(j + 2, 8) = d1(sht.Cells(j + 2, 2).Value).items
    
41.             sht.Cells(j + 2, 9) = d2(sht.Cells(j + 2, 2).Value).items
    
42.             sht.Cells(j + 2, 10) = d3(sht.Cells(j + 2, 2).Value).items
    
43.             'v = v + 1
    
44.         Else
    
45.             sht.Rows(j + 2 + 1).EntireRow.Resize(d(sht.Cells(j + 2, 2).Value).Count - 1).Insert
    
46.             sht.Cells(j + 2, 6).Resize(d(sht.Cells(j + 2, 2).Value).Count, 1) = Application.Transpose(d(sht.Cells(j + 2, 2).Value).keys)
    
47.             sht.Cells(j + 2, 7).Resize(d(sht.Cells(j + 2, 2).Value).Count, 1) = Application.Transpose(d(sht.Cells(j + 2, 2).Value).items)
    
48.             sht.Cells(j + 2, 8).Resize(d(sht.Cells(j + 2, 2).Value).Count, 1) = Application.Transpose(d1(sht.Cells(j + 2, 2).Value).items)
    
49.             sht.Cells(j + 2, 9).Resize(d(sht.Cells(j + 2, 2).Value).Count, 1) = Application.Transpose(d2(sht.Cells(j + 2, 2).Value).items)
    
50.             sht.Cells(j + 2, 10).Resize(d(sht.Cells(j + 2, 2).Value).Count, 1) = Application.Transpose(d3(sht.Cells(j + 2, 2).Value).items)
    
51.                 For Z = 2 To 5
    
52.                     sht.Cells(j + 2, Z).Resize(d(sht.Cells(j + 2, 2).Value).Count, 1).MergeCells = True
    
53.                 Next Z
    
54.             'v = v + d(sht.Cells(j + 2, 2).Value).Count
    
55.         End If
    
56.       End If
    
57.     Next
    
58. Application.ScreenUpdating = True
    
59. End Sub
    

复制代码

劳务数据查询-修改.rar (30.61 KB, 下载次数: 3)

2020-10-13 15:43 上传

点击文件名下载附件

谢谢老师，根据需要，对原始数据及格式，修改了下，然后把自己想要的结果，根据老师您的代码修改了下，感谢。

1016373263

lele400024 发表于 2020-10-13 15:44
谢谢老师，根据需要，对原始数据及格式，修改了下，然后把自己想要的结果，根据老师您的代码修改了下， ...

不容易，很行的

blackttea1

学习啦 ，谢谢