VBA中乱序提取各人员对应项目数据

yjwdjfqb

各位老师好
想用VBA，从表一，将数据提取到表二中
（表格中人员顺序、项目顺序不一致）
请老师们帮帮忙，谢谢老师们了！
Excel中VBA乱序提取各人员对应数据.rar (8.41 KB, 下载次数: 9)

2024-3-14 20:43 上传

点击文件名下载附件

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Sheets("表一").[D4].CurrentRegion.Value
    For i = 2 To UBound(ar)
        For j = 2 To UBound(ar, 2)
             dic(ar(i, 1) & ar(1, j)) = ar(i, j)
        Next j
    Next i
    With Sheets("表二")
        ar = .[C5].CurrentRegion.Value
        For i = 2 To UBound(ar)
            For j = 2 To UBound(ar, 2)
                ar(i, j) = dic(ar(1, j) & ar(i, 1))
            Next j
        Next i
        .[C5].CurrentRegion.Value = ar
        .Activate
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

chxw68

练练手。。。

yanglinzi

1. Sub 提取数据()
   
2. Dim arr, brr, i, j, d, s
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.UsedRange
   
5. brr = Sheet2.UsedRange
   
6. For j = 2 To UBound(arr, 2)
   
7.     For i = 5 To UBound(arr)
   
8.         s = arr(4, j)
   
9.         xs = arr(i, 1)
   
10.         If Not d.exists(s) Then
    
11.             Set d(s) = CreateObject("scripting.dictionary")
    
12.         End If
    
13.         d(s)(xs) = arr(i, j)
    
14.     Next
    
15. Next
    
16. For j = 2 To UBound(brr, 2)
    
17.     For i = 6 To UBound(brr)
    
18.         s = brr(i, 1)
    
19.         xs = brr(5, j)
    
20.         brr(i, j) = d(s)(xs)
    
21.     Next
    
22. Next
    
23. Sheet2.UsedRange = brr
    
24. End Sub
    

复制代码

yanglinzi

请测试。。

ykcbf1100

参与一下。。。

ykcbf1100

重在参与。。。

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

复制代码

yjwdjfqb

非常感谢各位老师的帮助，今天没有花花了，后面补上，谢谢老师们！！！