修改代码

ddz79101

老师！有2张表，其中1张表需要提取另1表的3列金额，虽有代码，但未能成功。请老师帮忙看看。谢谢

quqiyuan

供参考

quqiyuan

Sub 提()
    Dim arr, brr
    arr = Sheets("票").[A1].CurrentRegion
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(arr)
        d(arr(i, 4)) = i
    Next
    With Sheets("中心")
        r = .Range("d" & Rows.Count).End(xlUp).Row
        .Range("f2:h" & r + 1) = Empty
        brr = .[d2].Resize(r, 5)
        For i = 1 To UBound(brr)
            s = brr(i, 1)
            If d.Exists(s) Then
                For j = 7 To 9
                    brr(i, j - 4) = arr(d(s), j)
                Next
            End If
        Next
        .[d2].Resize(r, 5) = brr
    End With
End Sub

chxw68

猜测着修改的。

ykcbf1100

附件供参考。。。

ykcbf1100

新写一个吧。

1. Sub ykcbf()   '//2024.6.3
   
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.         arr = .[d1].Resize(r, 6)
   
8.     End With
   
9.     For i = 2 To UBound(arr)
   
10.         s = CStr(arr(i, 1))
    
11.         d(s) = i
    
12.     Next
    
13.     On Error Resume Next
    
14.     With Sheets("中心")
    
15.         r = .Cells(.Rows.Count, "d").End(xlUp).Row
    
16.         brr = .[d1].Resize(r, 5)
    
17.         For i = 2 To UBound(brr)
    
18.             s = CStr(brr(i, 1))
    
19.             If d.Exists(s) Then
    
20.                 .Cells(i, 6) = arr(d(s), 4)
    
21.                 .Cells(i, 7) = arr(d(s), 5)
    
22.                 .Cells(i, 8) = arr(d(s), 6)
    
23.             End If
    
24.         Next
    
25.     End With
    
26.     Set d = Nothing
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    

复制代码

Qs18

Sub test()
Dim ar, br, dic As Object, i, j, s, ss
ar = Sheet10.UsedRange.Value
br = Sheet9.UsedRange.Value
For i = 2 To UBound(br)
    s = br(i, 4)
    For j = 2 To UBound(ar)
        ss = ar(j, 4)
        If s = ss Then
            br(i, 6) = ar(j, 7)
            br(i, 7) = ar(j, 8)
            br(i, 8) = ar(j, 9)
            Exit For
        End If
   
   
    Next
Next
Sheet9.Range("a1").Resize(UBound(br), UBound(br, 2)) = br
MsgBox "完成！"
End Sub

gwjkkkkk

公式也比较简单

Qs18

试一下。。。。

gwjkkkkk

1. =IFERROR(VLOOKUP($D2,票!$D:$I,COLUMN()-2,),"")

复制代码

右拉下拉