求助各位大佬一个复杂的匹配难题

笨鸟飞不高

ynzsvt

1. Sub 找时间上的上级头领()
   
2. Dim Arr, i&, Dic As Object
   
3. Dim Brr, j&, Dk, MinDk As Date, Crr
   
4. 
   
5. Arr = [H1:L20]
   
6. Set Dic = CreateObject("Scripting.Dictionary")
   
7. 
   
8. For i = 2 To UBound(Arr)
   
9.   For j = 3 To 5
   
10.    If Len(Arr(i, j)) <> 0 Then
    
11.     If Not Dic.Exists(Arr(i, j)) Then Set Dic(Arr(i, j)) = CreateObject("Scripting.Dictionary")
    
12.     Dic(Arr(i, j))(Arr(i, 1)) = i
    
13.    End If
    
14.   Next
    
15. Next
    
16. 
    
17. Brr = [A2:C40]
    
18. ReDim Crr(1 To UBound(Brr), 1 To 3)
    
19. For i = 1 To UBound(Brr)
    
20.   If Brr(i, 1) <> "" Then
    
21.    MinDk = Date
    
22.    Dk = Dic(Brr(i, 1)).Keys
    
23.    For j = 0 To UBound(Dk)
    
24.     If Dk(j) >= Brr(i, 3) Then
    
25.      If MinDk > Dk(j) Then MinDk = Dk(j)
    
26.     End If
    
27.    Next
    
28.    j = Dic(Brr(i, 1))(MinDk)
    
29.    If Brr(i, 1) = Arr(j, 3) Then
    
30.     Crr(i, 2) = Arr(j, 3)
    
31.    ElseIf Brr(i, 1) = Arr(j, 4) Then
    
32.     Crr(i, 2) = Arr(j, 3): Crr(i, 1) = Arr(j, 4)
    
33.    ElseIf Brr(i, 1) = Arr(j, 5) Then
    
34.     Crr(i, 2) = Arr(j, 3): Crr(i, 1) = Arr(j, 4)
    
35.    End If
    
36.    Crr(i, 3) = Arr(j, 2)
    
37.   End If
    
38. Next
    
39. 
    
40. [D2].Resize(UBound(Crr), 3) = Crr
    
41. Set Dic = Nothing
    
42. End Sub

复制代码

ynzsvt

同级的要显示代码更改部分 更改后效果图

1.    j = Dic(Brr(i, 1))(MinDk)
   
2.    If Brr(i, 1) = Arr(j, 3) Then
   
3.     Crr(i, 2) = Arr(j, 3)
   
4.    ElseIf Brr(i, 1) = Arr(j, 4) Then
   
5.     Crr(i, 2) = Arr(j, 3): Crr(i, 1) = Arr(j, 4)
   
6.    ElseIf Brr(i, 1) = Arr(j, 5) Then
   
7.     Crr(i, 2) = Arr(j, 3): Crr(i, 1) = Arr(j, 4)
   
8.    End If
   
9.    Crr(i, 3) = Arr(j, 2)

复制代码

幽默的熊

joy.008@163.com 发表于 2024-8-14 16:38
参与一下~~~

大佬厉害!!  我得再好好理解理解这个代码, 学到了学到了!!

幽默的熊

笨鸟飞不高 发表于 2024-8-14 16:57

又是一个思路 , 感谢大佬

幽默的熊

ynzsvt 发表于 2024-8-14 16:59

感谢大佬!  学到了学到了!

幽默的熊

小凡、、、 发表于 2024-8-14 14:55
是这样的结果？

没错啦! 辛苦大佬费心

usedrange

1. Sub tt()
   
2.     Dim ar, br, cr, i%, t, s, d, df, n%
   
3.     ar = [a1].CurrentRegion
   
4.     Set br = [i1].CurrentRegion
   
5.     Set cr = [o2:o6]
   
6.     For i = 2 To UBound(ar)
   
7.         Set t = br.Find(ar(i, 1))
   
8.         If Not t Is Nothing And ar(i, 1) <> "" Then
   
9.             If InStr("头领|上级", Cells(1, t.Column)) > 0 Then
   
10.                 ar(i, 4) = ar(i, 1)
    
11.                 ar(i, 5) = ar(i, 1)
    
12.                 ar(i, 6) = Cells(t.Row, 9)
    
13.             Else
    
14.                 ar(i, 4) = Cells(t.Row, t.Column - 1)
    
15.                 ar(i, 5) = Cells(t.Row, t.Column - 2)
    
16.                 ar(i, 6) = Cells(t.Row, t.Column - 3)
    
17.             End If
    
18.         End If
    
19.         Set s = cr.Find(ar(i, 1))
    
20.         If Not s Is Nothing And ar(i, 1) <> "" Then
    
21.             d = s.Offset(0, 1).Value        '变更表的日期
    
22.             df = DateDiff("d", ar(i, 3), d) '与变更表日期的相隔天数
    
23.             If ar(i, 1) = "吕布" Then
    
24.                 n = 3
    
25.                 Do While DateDiff("d", ar(i, 3), Cells(n, "p")) >= 0
    
26.                     ar(i, 4) = Cells(n, "p").Offset(0, 1)
    
27.                     ar(i, 5) = Cells(n, "p").Offset(0, 2)
    
28.                     ar(i, 6) = Cells(n, "p").Offset(0, 3)
    
29.                     n = n - 1
    
30.                     If n < 2 Then Exit Do
    
31.                 Loop
    
32.             ElseIf df >= 0 Then
    
33.                 ar(i, 4) = Cells(s.Row, "p").Offset(0, 1)
    
34.                 ar(i, 5) = Cells(s.Row, "p").Offset(0, 2)
    
35.                 ar(i, 6) = Cells(s.Row, "p").Offset(0, 3)
    
36.             End If
    
37.         End If
    
38.         Set s = Nothing
    
39.         Set t = Nothing
    
40.     Next i
    
41.     [a1].Resize(UBound(ar), 6) = ar
    
42.     Set br = Nothing
    
43.     Set cr = Nothing
    
44. End Sub
    

复制代码