求帮忙写个提取实发金额VBA代码，谢谢~

ruhong18

求帮忙写个提取实发金额VBA代码，谢谢~

蓝桥玄霜

1. Sub gj23w98()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("201908月针织部")
   
4.         r = .Cells(.Rows.Count, 2).End(3).Row
   
5.         arr = .[a1].Resize(r, 26)
   
6.     End With
   
7.     For i = 5 To UBound(arr)
   
8.         s = arr(i, 2)
   
9.         If s <> "" Then d(s) = arr(i, 25)
   
10.     Next
    
11.     With Sheets("201908月拉毛部")
    
12.         r = .Cells(.Rows.Count, 2).End(3).Row
    
13.         arr = .[a1].Resize(r, 18)
    
14.     End With
    
15.     For i = 5 To UBound(arr)
    
16.         s = arr(i, 2)
    
17.         If s <> "" Then d(s) = arr(i, 17)
    
18.     Next
    
19.     r = Cells(Rows.Count, 4).End(3).Row
    
20.     brr = [a1].Resize(r, 10)
    
21.     For i = 4 To UBound(brr)
    
22.         s = brr(i, 4) ' & brr(i, 3))
    
23.         If d.exists(s) Then Cells(i, 8) = d(s)
    
24.     Next
    
25.     MsgBox "提取金额成功！"
    
26. End Sub
    

复制代码

ruhong18

问题已解决；感恩，感谢老师！

yylucke

请参考附件
1、无论表名怎么改，只要包含“针织部"、"拉毛部"均能提取数据
2、你的《银行卡号明细》H列名称错误，应为实发工资
3、无论“实发工资"在哪一列（但必须在第2行）均能提取数据。
求帮忙写个VBA代码 的副本.rar (44.25 KB, 下载次数: 2)

2019-9-17 15:24 上传

点击文件名下载附件

yylucke

Sub gj23w98()
Set DicResult = CreateObject("Scripting.Dictionary")
With Sheet3
    r = .Cells(.Rows.Count, 4).End(3).Row
    For i = 4 To r
        DicResult(.Cells(i, 3).Value & "-" & .Cells(i, 4).Value) = .Cells(i, 23).Value
    Next i
End With


For Each sh In Sheets
    TmpStartStr = ""
    Select Case True
    Case InStr(sh.Name, "针织部") > 0
        TmpStartStr = "针织部-"
    Case InStr(sh.Name, "拉毛部") > 0
        TmpStartStr = "拉毛部-"
    End Select
    If TmpStartStr = "" Then GoTo Line5
   
    With sh
        If sh.Name = ActiveSheet.Name Then GoTo Line5
        MyColumn = Application.Match("实发工资", .Rows(2), 0)
        If IsError(MyColumn) Then MsgBox "表" & sh.Name & "没有【实发工资】列！": GoTo Line5
        r = .Cells(.Rows.Count, 2).End(3).Row
        For i = 4 To r
            TmpKey = TmpStartStr & .Cells(i, 2).Value
            If DicResult.Exists(TmpKey) Then DicResult(TmpKey) = Round(.Cells(i, MyColumn).Value, 0)
        Next i
    End With
Line5:
Next sh

With Sheet3
    .Range("H4").Resize(DicResult.Count, 1) = Application.Transpose(DicResult.items)
End With

    MsgBox "提取金额成功！"
End Sub

ruhong18

yylucke 发表于 2019-9-17 15:24
Sub gj23w98()
Set DicResult = CreateObject("Scripting.Dictionary")
With Sheet3

感谢老师，代码正确，感恩，感谢！

yylucke

ruhong18 发表于 2019-9-17 15:48
感谢老师，代码正确，感恩，感谢！

此代码优点：
1、无论sheet命名如何，只要包含“拉毛、针织”均可正确提取数据
2、无论实发工资在哪列（只要在第2行）就可正确提取数据
3、防止了不同车间同姓名的问题（但是不治本，最好用身份证号来识别）