二维表查找的VBA代码

xkx590

各位高手：二维表查找的VBA代码如何写？

问题已解决，谢谢各位高手帮忙！

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.5.9
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("数据")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 4)
   
8.     End With
   
9.     For i = 2 To UBound(arr)
   
10.         s = arr(i, 1)
    
11.         d(s) = i
    
12.     Next
    
13.     For j = 2 To UBound(arr, 2)
    
14.         s = arr(1, j)
    
15.         d(s) = j
    
16.     Next
    
17.     With Sheets("查找")
    
18.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
19.         brr = .[a1].Resize(r, 4)
    
20.         For i = 2 To UBound(brr)
    
21.             s = brr(i, 1)
    
22.             If d.Exists(s) Then
    
23.                 For j = 2 To UBound(brr, 2)
    
24.                     ss = brr(1, j)
    
25.                     brr(i, j) = arr(d(s), d(ss))
    
26.                 Next
    
27.             End If
    
28.         Next
    
29.         .[a1].Resize(r, 4) = brr
    
30.     End With
    
31.     Set d = Nothing
    
32.     Application.ScreenUpdating = True
    
33.     MsgBox "OK！"
    
34. End Sub
    
35. 
    

复制代码

feilanga

1. Sub zc()
   
2.     arr = Sheet2.UsedRange
   
3.     Dim dic As Object
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     For i = 2 To UBound(arr)
   
6.         For j = 2 To UBound(arr, 2)
   
7.             If Len(arr(i, 1)) > 0 Then
   
8.                 Key = arr(i, 1) & "," & arr(1, j)
   
9.                 dic(Key) = arr(i, j)
   
10.             End If
    
11.         Next
    
12.     Next
    
13.     arr = Sheet1.UsedRange
    
14.     For i = 2 To UBound(arr)
    
15.         For j = 2 To UBound(arr, 2)
    
16.             Key = arr(i, 1) & "," & arr(1, j)
    
17.             If dic.Exists(Key) Then
    
18.                 arr(i, j) = dic(Key)
    
19.             End If
    
20.         Next
    
21.     Next
    
22.     Sheet1.UsedRange = arr
    
23. End Sub

复制代码

feilanga

gwjkkkkk

Option Explicit
Sub TEST5()
    Dim ar, i&, j&, dic As Object, strKey$
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Sheets(2).[A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        For j = 2 To UBound(ar, 2)
            strKey = ar(i, 1) & ar(1, j)
            dic(strKey) = ar(i, j)
        Next j
    Next i
   
    ar = [A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        For j = 2 To UBound(ar, 2)
            strKey = ar(i, 1) & ar(1, j)
            ar(i, j) = dic(strKey)
        Next j
    Next i
   
    [A1].CurrentRegion.Value = ar
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

.........

xkx590

ykcbf1100 发表于 2024-5-9 10:17
附件供参考。。。

谢谢高手帮忙！

xkx590

feilanga 发表于 2024-5-9 10:24

谢谢高手帮忙！

xkx590

gwjkkkkk 发表于 2024-5-9 10:36
.........

谢谢高手帮忙！