求对应数据的问题

杨小妹

附件 求对应数据.rar (273.07 KB, 下载次数: 10)

2024-3-7 19:45 上传

点击文件名下载附件

谢谢老师！

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.         arr = .Range("a1:f" & r)
   
9.         For i = 1 To UBound(arr)
   
10.             xm = arr(i, 1) & "+" & arr(i, 2) & "+" & arr(i, 3) & "+" & arr(i, 4)
    
11.             d(xm) = arr(i, 6)
    
12.         Next
    
13.         r = .Cells(.Rows.Count, 8).End(xlUp).Row
    
14.         arr = .Range("h1:m" & r)
    
15.         For i = 1 To UBound(arr)
    
16.             xm = arr(i, 1) & "+" & arr(i, 2) & "+" & arr(i, 3) & "+" & arr(i, 4)
    
17.             If d.exists(xm) Then
    
18.                 arr(i, 6) = d(xm)
    
19.             End If
    
20.         Next
    
21.         .Range("h1:m" & r) = arr
    
22.     End With
    
23. End Sub
    

复制代码

chxw68

详见附件。

gwjkkkkk

Option Explicit
Sub TEST2()
    Dim ar, br, cr, i&, j&, k&, strJoin1$, strJoin2$
    Application.ScreenUpdating = False
   
    ar = Range("A1", Cells(Rows.Count, "F")).Value
    br = [H1].CurrentRegion.Value
    ReDim cr(1 To UBound(br), 0)
   
    For i = 1 To UBound(br)
        strJoin1 = "," & Join(Application.Index(br, i), ",")
        For k = 1 To UBound(ar)
            strJoin2 = ""
            For j = 1 To UBound(br, 2)
                strJoin2 = strJoin2 & "," & ar(k, j)
            Next j
            If strJoin2 = strJoin1 Then cr(i, 0) = ar(k, UBound(ar, 2)): Exit For
        Next k
    Next i
   
    Columns("M").Clear
    [M1].Resize(UBound(cr)) = cr
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。