文件：yhd-VBA编外追回工资模板自动填写工具.xlsm
【解决问题】在工作中我常要做的事：在几个文件中，查找某人的数据，并复制出来，到一个新的文件中。
通常的手工做法是：
- 打开工资文件--查找--复制--粘贴到新文件中--关闭文件，完成1个
- 打开社保文件--查找--复制--粘贴到新文件中--关闭文件，完成2个
- 打开公积金文件--查找--复制--粘贴到新文件中--关闭文件，完成3个
再计算出合计=工资 社保 公积金，再用姓名 合计做为文件名另存为一个新的工作簿，保存起来再发给相应的人。
这样做完了要的时间约8分钟，查找一个人还好，如果查找10人，做着做着也乱了。
所以…………
想想有没有方法，两个字：快、准
【代码】
代码语言：javascript复制Sub yhd查询多文件输入模板生成新文件()
Dim arr
Dim wb As Object
With Worksheets("设置")
endrow = .Range("D10000").End(xlUp).Row
If endrow <= 3 Then MsgBox "还有设置初值": Exit Sub
Call CheckBlank(.Range("D4:H" & endrow))
'取得要查找的数据源数据
arr = .Range("D4:H" & endrow)
'取得姓名与身份证（条件数组brr）
brr = .Range("A4:B" & .Range("A10000").End(xlUp).Row)
End With
t = Timer
Call disAppSet(False)
Set thisWb = ThisWorkbook
For a = 1 To UBound(brr)
'循环条件数组brr
wsh_num = Worksheets.Count
Worksheets("模板").Copy After:=Worksheets(wsh_num)
'复制“模板”文件为新的工作表，等待输入数据
For i = 1 To UBound(arr)
'打开文件，i行1列=文件路径
Set wb = GetObject(arr(i, 1))
'进入打开文件的工作表，i行2列=工作表名,
With wb.Worksheets(arr(i, 2))
endrow = .Cells.Find("*", , , , 1, 2).Row
For j = 1 To endrow
' Debug.Print .Cells(j, arr(i, 3)), UCase(.Cells(j, arr(i, 4)))
If .Cells(j, arr(i, 3)) = brr(a, 1) And UCase(.Cells(j, arr(i, 4))) = UCase(brr(a, 2)) Then
'如果3=姓名=姓名 and 4=大写身份证=大写身份证，则复制整行数据
.Range("A" & j).EntireRow.Copy thisWb.Worksheets(wsh_num 1).Cells(arr(i, 5), 1)
outtext = outtext & arr(i, 1) & "-找到数据" & Chr(10)
Exit For
Else
'== MsgBox arr(i, 1) & Chr(10) & "中没找到数据"
End If
Next j
End With
wb.Close False
Next i
Application.Calculation = xlCalculationAutomatic
With Worksheets(wsh_num 1)
.Range("B5:D5").Copy .Range("B19:D19")
.Range("B1") = brr(a, 1) & .Range("B1")
saveName = brr(a, 1) & .Range("H19")
.Move
End With
'移动复制出来的工作表，另存为新的工作簿
' Worksheets(wsh_num 1).Move
ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & saveName & ".xlsx"
ActiveWorkbook.Worksheets(1).Name = "模板"
ActiveWorkbook.Close SaveChanges:=True
Next a
thisWb.Worksheets("设置").Activate
Call disAppSet(True)
MsgBox "用时：" & Timer - t & Chr(10) & outtext
End Sub
'========CheckBlank检测空值，如果有空就退出=========
'使用方法
' Dim r As Range
' Set r = Union(Range("M4:O4"), Range("M8:O8"))
' Call CheckBlank(r)
'=================
Sub CheckBlank(rng)
For Each r In rng
If Application.WorksheetFunction.CountBlank(r) Then
MsgBox "你在" & r.Address & "没有填写内容"
Exit Sub
End If
Next
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 SelectFile()
'选择单一文件
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path
'单选择
.Filters.Clear
'清除文件过滤器
.Filters.Add "Excel Files", "*.xls*;*.xlw"
.Filters.Add "All Files", "*.*"
'设置两个文件过滤器
If .Show = -1 Then
'FileDialog 对象的 Show 方法显示对话框，并且返回 -1（如果您按 OK）和 0（如果您按 Cancel）。
'MsgBox "您选择的文件是：" & .SelectedItems(1), vbOKOnly vbInformation, "提示"
filepath = .SelectedItems(1)
With Worksheets("设置")
.Range("D" & .Range("D10000").End(xlUp).Row 1) = filepath
End With
End If
End With
End Sub
【使用方法】
- 复制--粘贴要查询的数据
- 设置好初始数据参数--执行
实测：时间差：10人，1小时工作量减少为30秒左右
