新新---求助VBA同工作薄查找引用-新问题

wzp8888

新新---求助VBA同工作薄查找引用-新问题，详见附件！！



急急急！！！

wzp8888

或者根据附件内代码修改为：同工作簿内查找引用，附件代码为跨文件夹引用案例

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf2()  '//2024.4.28
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("汇总表")
   
4.         r = .Cells(Rows.Count, 5).End(3).Row
   
5.         c = .UsedRange.Columns.Count
   
6.         arr = .[a1].Resize(r, c)
   
7.     End With
   
8.     For j = 5 To UBound(arr, 2)
   
9.         s = arr(10, j)
   
10.         d(s) = j
    
11.     Next
    
12.     For i = 11 To UBound(arr)
    
13.         s = arr(i, 5)
    
14.         d(s) = i
    
15.     Next
    
16.     On Error Resume Next
    
17.     With Sheets("总表")
    
18.         r = .Cells(Rows.Count, 5).End(3).Row
    
19.         c = .Cells(10, 255).End(1).Column
    
20.         brr = .[a1].Resize(r, c)
    
21.         For i = 11 To UBound(brr)
    
22.             For j = 5 To UBound(brr, 2)
    
23.                 brr(i, j) = arr(d(brr(i, 5)), d(brr(10, j)))
    
24.             Next
    
25.         Next
    
26.         .[a1].Resize(r, c) = brr
    
27.         .[a1].Resize(r, c).EntireColumn.AutoFit
    
28.     End With
    
29.     Set d = Nothing
    
30.     MsgBox "OK！"
    
31. End Sub
    
32. 
    

复制代码

shiruiqiang

ykcbf老师代码上修改一下就行，字典嵌套

wzp8888

ykcbf1100 发表于 2024-4-28 19:52
附件供参考。。。

摩拜大神，非常感谢，解决了我的大难题。。。。再次感谢！！！

wzp8888

shiruiqiang 发表于 2024-4-28 19:58
ykcbf老师代码上修改一下就行，字典嵌套

本人VBA菜鸟，感谢各位老师的指教

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, r&, dic As Object, Rng As Range, strKey$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With Sheets("汇总表")
        r = .Cells(Rows.Count, "E").End(xlUp).Row
        Set Rng = .Range("e10:xfd" & r)
        ar = Intersect(.UsedRange, Rng).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
    End With
   
    r = Cells(Rows.Count, "E").End(xlUp).Row
    Set Rng = Range("e10:xfd" & r)
    With Intersect(ActiveSheet.UsedRange, Rng)
        ar = .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)
                If IsDate(ar(i, j)) Then ar(i, j) = "'" & ar(i, j)
            Next j
        Next i
        .Value = ar
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。

wzp8888

gwjkkkkk 发表于 2024-4-28 20:15
参与一下。。。

太感谢了，大神们。。。。非常完美。。。。