VBA全自动录入“个人所得税的正常工资”文件模板

哆哆Excel

发布于 2022-10-31 15:30:11

4380

发布于 2022-10-31 15:30:11

文章被收录于专栏：哆哆Excel哆哆Excel

【保存自己工作的代码，方便以后使用】

【问题】

我们在做个人所得税时，我们需要导入“正常工资”模板文件，模板文件要录入的数据有“本期收入、基本养老保险费、基本医疗保险费、失业保险费、住房公积金、企业(职业)年金”有4000多人，以前用VLookup进行引用数据，每次做都要很长时间。

有没有快一点的方法

经过努力终于完成

VBA全自动录入“个人所得税的正常工资”文件模板.xlam

【代码如下】

Sub 自动输入正常工资()
    Dim arr, brr, temp_rr
    Dim wb_in As Workbook, wb_out As Workbook
    Dim dic_in As Object, dic_out As Object
    Set dic_in = CreateObject("scripting.dictionary")
    Set dic_out = CreateObject("scripting.dictionary")
    With Sheets("main")
        arr = .Range("B3").Resize(1, .Range("B3").End(xlToRight).Column - 1)
        brr = .Range("B7").Resize(2, .Range("B7").End(xlToRight).Column - 1)

    End With
Call disAppSet(False)
    For j = 1 To UBound(brr)
        Set wb_out = Workbooks.Open(brr(j, 1))
        With wb_out.Sheets(brr(j, 2))
            endrow = .Cells.Find("*", , , , 1, 2).Row
            For shtj = 5 To endrow
                s = .Cells(shtj, brr(j, 3)) & .Cells(shtj, brr(j, 4))
                If Len(s) > 0 Then
                    dic_out(s) = .Cells(shtj, brr(j, 5)) & "@" & .Cells(shtj, brr(j, 6)) & "@" & .Cells(shtj, brr(j, 7)) & "@" & .Cells(shtj, brr(j, 8)) & "@" & .Cells(shtj, brr(j, 9)) & "@" & .Cells(shtj, brr(j, 10))
'                    Array(.Cells(shtj, brr(j, 5)), .Cells(shtj, brr(j, 6)), .Cells(shtj, brr(j, 7)), .Cells(shtj, brr(j, 8)), .Cells(shtj, brr(j, 9)), .Cells(shtj, brr(j, 10)))
                End If
            Next shtj
            
        End With '====wb_out.Sheets(brr(j, 2))
        wb_out.Close False
        
    Next j
        'arr(1,1)是文件路径，arr(1,2)是工作表名
    Set wb_in = Workbooks.Open(arr(1, 1))
    With wb_in.Sheets(arr(1, 2))
        endrow = .Cells.Find("*", , , , 1, 2).Row
        For i = 2 To endrow
            s = .Cells(i, arr(1, 3)) & .Cells(i, arr(1, 4))
            If dic_out.exists(s) Then
                temp_rr = Split(dic_out(s), "@")
'                MsgBox dic_out(s)
                .Cells(i, arr(1, 5)) = temp_rr(0)
                .Cells(i, arr(1, 6)) = temp_rr(1)
                .Cells(i, arr(1, 7)) = temp_rr(2)
                .Cells(i, arr(1, 8)) = temp_rr(3)
                .Cells(i, arr(1, 9)) = temp_rr(4)
                .Cells(i, arr(1, 10)) = temp_rr(5)

            End If
        Next i

    End With '====wb_in.Sheets(arr(1, 2))
'    wb_in.Close True
    Call disAppSet(True)
    MsgBox "完成"
End Sub

Sub disAppSet(flag As Boolean)
With Application
    .ScreenUpdating = flag
    .DisplayAlerts = flag
    .AskToUpdateLinks = flag
    If flag Then
        .Calculation = xlCalculationAutomatic
    Else
        .Calculation = xlCalculationManual
    End If
End With
End Sub

【使用方法】

准备好数据

画圈的要自己录入

参数录入好了，按【执行】就可以啦

几秒完成。

以后就不用那么长时间啦

【选择按钮的代码】

Sub toB_3()
    Call SelectFile("B3")
End Sub
Sub toB_7()
    Call SelectFile("B7")
End Sub
Sub toB_8()
    Call SelectFile("B8")
End Sub
'===选择文件取得路径输入到指定单元格=============
Sub SelectFile(rng As String)
    '选择单一文件
    With Application.FileDialog(msoFileDialogFilePicker)
        .InitialFileName = ThisWorkbook.Path
        .AllowMultiSelect = False
        '单选择
        .Filters.Clear
        '清除文件过滤器
        .Filters.Add "Excel Files", "*.xl*"
'        .Filters.Add "All Files", "*.*"
        '设置两个文件过滤器
        If .Show = -1 Then
            'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
             ActiveSheet.Range(rng) = .SelectedItems(1)
        End If
    End With
End Sub

【完成如图】