【保存自己工作的代码，方便以后使用】
【问题】
我们在做个人所得税时，我们需要导入“正常工资”模板文件，模板文件要录入的数据有“本期收入 、基本养老保险费、 基本医疗保险费、失业保险费、住房公积金、企业(职业)年金”有4000多人，以前用VLookup进行引用数据，每次做都要很长时间。
有没有快一点的方法
经过努力终于完成
VBA全自动录入“个人所得税的正常工资”文件模板.xlam
【代码如下】
代码语言：javascript复制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
【使用方法】
准备好数据
画圈的要自己录入
参数录入好了，按【执行】就可以啦
几秒完成。
以后就不用那么长时间啦
【选择按钮的代码】
代码语言：javascript复制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
【完成如图】
接下去就是在"电子税务系统"中导入文件就可以啦
