VBA一键提取4个excel社保文件的指定单元格
【问题】平时提取4个文件的数据时，是打开一个文件，复制数据，再打开一个文件，复制数据，再打开一个文件，复制数据，再打开一个文件，复制数据，用时要30分以上，于是我总想能不能快一点，今天写个代码来完成这个工作用时1.69秒。
【说明】此代码只是适合自己，做为自己的备份
代码语言：javascript复制第一步：取得4个文件的路径
Sub toc_2()
SelectFile ("C2")
End Sub
Sub toc_3()
SelectFile ("C3")
End Sub
Sub toc_4()
SelectFile ("C4")
End Sub
Sub toc_5()
SelectFile ("C5")
End Sub
Sub SelectFile(rng)
'选择单一文件
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）。
Sheets("设置表").Range(rng) = .SelectedItems(1)
End If
End With
End Sub
第二步：取得相关的数据
Sub cle()
With Sheets("设置表")
.Range("A10:N10") = ""
End With
End Sub
Sub ffffffffffffff()
Dim Wb, ws
Dim arr(13)
t = Timer()
With Sheets("设置表")
.Range("A10:N10") = ""
If Application.WorksheetFunction.CountA(.Range("c2:c5")) = 4 Then
sb_file = .Range("c2").Value
smzx_file = .Range("c3").Value
smxx_file = .Range("c4").Value
lcsx_file = .Range("c5").Value
Else
MsgBox "有单元格没填写"
Exit Sub
End If
End With
Application.ScreenUpdating = False
'''========社保文件==============
myfile = sb_file '
Set Wb = GetObject(myfile)
Set ws = Wb.Worksheets(1)
With ws
LastRow = .Cells.Find("*", , , , 1, 2).Row
getRow = LastRow - 4
Debug.Print getRow
arr(1) = .Range("U" & getRow) '社保养老应
arr(2) = .Range("Z" & getRow) '社保养老补
arr(3) = .Range("AF" & getRow) '职业年金应
arr(4) = .Range("AK" & getRow) '职业年金补
End With
Wb.Close False
'''========XXXX中学==============
myfile = smzx_file
Set Wb = GetObject(myfile)
Set ws = Wb.Worksheets(1)
With ws
LastRow = .Cells.Find("*", , , , 1, 2).Row
getRow = LastRow
Debug.Print getRow
arr(5) = .Range("a" & getRow - 1) '人数=序号最后一个
arr(6) = .Range("j" & getRow) '养老单位数据
arr(7) = .Range("o" & getRow) '职业单位数据
End With
Wb.Close False
'''========XXXX小学==============
myfile = smxx_file
Set Wb = GetObject(myfile)
Set ws = Wb.Worksheets(1)
With ws
LastRow = .Cells.Find("*", , , , 1, 2).Row
getRow = LastRow
Debug.Print getRow
arr(8) = .Range("a" & getRow - 1) '人数=序号最后一个a
arr(9) = .Range("i" & getRow) '养老单位数据=I
arr(10) = .Range("l" & getRow) '职业单位数据=L
End With
Wb.Close False
'''========XXX小学==============
myfile = lcsx_file
Set Wb = GetObject(myfile)
Set ws = Wb.Worksheets(1)
With ws
LastRow = .Cells.Find("*", , , , 1, 2).Row
getRow = LastRow
Debug.Print getRow
arr(11) = .Range("a" & getRow - 1) '人数=序号最后一个
arr(12) = .Range("h" & getRow) '养老单位数据
arr(13) = .Range("k" & getRow) '职业单位数据
End With
Wb.Close False
With Sheets("设置表")
For i = 0 To UBound(arr)
.Cells(10, i 1) = arr(i)
Next i
End With
Application.ScreenUpdating = True
MsgBox "完成，用时：" & Format(Timer() - t, "00.00秒")
End Sub
