请各位老帮忙：复杂的双条件引用

laoshenji

各位老师，大家好。本求助附件发到函数与公式求助无解，现转到VBA板块求助，请各位老师帮一下忙。谢谢大家！
本求助附件是要用VBA将《第2时段》（其中“个人名称”为乱序）的D列～L列的内容合并或引用到《第1时段》（其中“个人名称”为排序）的M列～U列。

山菊花

在同一姓名下的“科目名称”绝对不会重复。

发现下面这些记录有重复：

laoshenji

山菊花 发表于 2021-5-11 20:10
发现下面这些记录有重复：

万分感谢总版主的关怀。确实是您指出的那样，要不是总版主提醒，学生还不知道在对《第1时段》改名的时候出现了重复，由于《第2时段》也是在《第1时段》的基础上打乱的排序，所以也出现了同样错误。现在已对1楼附件进行了更新。对此，特向老师们致歉！

laoshenji

laoshenji 发表于 2021-5-12 09:03
万分感谢总版主的关怀。确实是您指出的那样，要不是总版主提醒，学生还不知道在对《第1时段》改名的时候 ...

静候大师们的佳音！

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr, crr, zrr()
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   With Worksheets("第2时段")
   
10.     r = .Cells(.Rows.Count, 4).End(xlUp).Row
    
11.     brr = .Range("d4:l" & r)
    
12.     For i = 1 To UBound(brr)
    
13.       If Not d.exists(brr(i, 1)) Then
    
14.         Set d(brr(i, 1)) = CreateObject("scripting.dictionary")
    
15.       End If
    
16.       d(brr(i, 1))(brr(i, 2)) = i
    
17.     Next
    
18.   End With
    
19.   With Worksheets("第1时段")
    
20.     r = .Cells(.Rows.Count, 4).End(xlUp).Row
    
21.     arr = .Range("d4:u" & r)
    
22.     m = 0
    
23.     For i = 1 To UBound(arr)
    
24.       If d.exists(arr(i, 1)) Then
    
25.         If d(arr(i, 1)).exists(arr(i, 2)) Then
    
26.           m = d(arr(i, 1))(arr(i, 2))
    
27.           For j = 1 To UBound(brr, 2)
    
28.             arr(i, j + 9) = brr(m, j)
    
29.           Next
    
30.           d(arr(i, 1)).Remove (arr(i, 2))
    
31.         End If
    
32.       End If
    
33.     Next
    
34.     For Each aa In d.keys
    
35.       If d(aa).Count = 0 Then
    
36.         d.Remove (aa)
    
37.       End If
    
38.     Next
    
39.     k = 0
    
40.     xm = Empty
    
41.     For i = 1 To UBound(arr)
    
42.       If arr(i, 1) <> xm Then
    
43.         k = k + 1
    
44.         ReDim Preserve zrr(1 To 2, 1 To k)
    
45.         zrr(1, k) = i
    
46.         zrr(2, k) = i
    
47.         xm = arr(i, 1)
    
48.       Else
    
49.         zrr(2, k) = i
    
50.       End If
    
51.     Next
    
52.     ReDim crr(1 To UBound(arr) * 2, 1 To UBound(arr, 2))
    
53.     m = 0
    
54.     For k = 1 To UBound(zrr, 2)
    
55.       For i = zrr(1, k) To zrr(2, k)
    
56.         m = m + 1
    
57.         For j = 1 To UBound(arr, 2)
    
58.           crr(m, j) = arr(i, j)
    
59.         Next
    
60.       Next
    
61.       If d.exists(arr(zrr(1, k), 1)) Then
    
62.         For Each bb In d(arr(zrr(1, k), 1)).keys
    
63.           m1 = d(arr(zrr(1, k), 1))(bb)
    
64.           m = m + 1
    
65.           For j = 1 To UBound(brr, 2)
    
66.             crr(m, j + 9) = brr(m1, j)
    
67.           Next
    
68.         Next
    
69.         d.Remove (arr(zrr(1, k), 1))
    
70.       End If
    
71.     Next
    
72.     For Each aa In d.keys
    
73.       For Each bb In d(aa).keys
    
74.         m1 = d(aa)(bb)
    
75.         m = m + 1
    
76.         For j = 1 To UBound(brr, 2)
    
77.           crr(m, j + 9) = brr(m1, j)
    
78.         Next
    
79.       Next
    
80.     Next
    
81.   End With
    
82.   With Worksheets("sheet1")
    
83.     .Range("d4").Resize(m, UBound(crr, 2)) = crr
    
84.     .Select
    
85.   End With
    
86.   Application.ScreenUpdating = True
    
87.   MsgBox "数据比对完毕！"
    
88. End Sub
    

复制代码

chxw68

楼主表述很清楚！结果在Sheet1里。

chxw68

第二种解法：使用了双字典，不要求第1时段数据排序。

laoshenji

chxw68 发表于 2021-5-13 09:54
第二种解法：使用了双字典，不要求第1时段数据排序。

万分感谢chxw68大师。

laoshenji

chxw68 发表于 2021-5-13 09:54
第二种解法：使用了双字典，不要求第1时段数据排序。

您请教老师，第7楼答案中有两个按钮是不是需要删除一个？

chxw68

修改好了。