哪位高手帮助下，最终实现“表2”的效果？

nedelux

哪位高手帮助下？最终实现“表2”的效果，谢谢啦！！！
1.当“表1”的F列为“是”时
2.查找“表3”的A列相同的值，并将该行的数据复制到表2中
3.表1的值一一对应复制到表2中

z865593849

提取数据

chxw68

详见附件。

ykcbf1100

用字典不难吧。

nedelux

z865593849 发表于 2024-12-13 16:42
提取数据

谢谢，wps下用不了

nedelux

chxw68 发表于 2024-12-13 16:44
详见附件。

谢谢，感谢，很好

ykcbf1100

字典，参与一下。

ykcbf1100

参与一下。。。

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

复制代码

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("a1").CurrentRegion.Value
   
5. For i = 2 To UBound(arr)
   
6.     s = arr(i, 6): ky = arr(i, 2)
   
7.     If s = "是" Then
   
8.         dic(ky) = Array(arr(i, 1), arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5))
   
9.     End If
   
10. Next i
    
11. arr = Sheet3.Range("a1").CurrentRegion.Value
    
12. ReDim brr(1 To UBound(arr), 1 To 9)
    
13. For i = 2 To UBound(arr)
    
14.     s = arr(i, 1)
    
15.     If dic.exists(s) Then
    
16.         m = m + 1
    
17.         iii = dic(s)
    
18.         For j = 0 To UBound(iii)
    
19.             brr(m, j + 1) = iii(j)
    
20.         Next
    
21.         For j = 2 To 5
    
22.             brr(m, j + 4) = arr(i, j)
    
23.         Next
    
24.     End If
    
25. Next
    
26. Sheet2.Range("a2").Resize(1000, 9) = ""
    
27. Sheet2.Range("a2").Resize(m, 9) = brr
    
28. Set dic = Nothing
    
29. End Sub
    

复制代码

Qs18

试试..........