ExcelVBA一键汇总文件夹中多Excel简历信息到一个Excel文件中

yhd-ExcelVBA一键汇总文件夹中多Excel简历信息到一个Excel文件中

上一次分享了一个汇总word文件的，现在分享一个汇总Excel文件的

======================

【问题】：公司招聘，有几百个来报名，报名表如下，我收集后要汇总在一个Excel文件中

====【常规作法】====

“打开~复制~粘贴~关闭~不保存”…………要几天重复的工作才做得完

====【目标】=====

一键完成

====【代码】====

Sub Macro1()

Dim wb As Workbook, myfile$, s&, i&, all_sht As Worksheet, column_arr, want_sht_name

Dim arr()

t = Timer

On Error Resume Next '如果遇到错误，不管错误，继续往下执行，但如果嵌套了其他错误处理语句，这些错误处理语句还是会按照自己规则运行

'On Error GoTo Err_Handle

Application.DisplayAlerts = False

Application.ScreenUpdating = False

myfile = Dir(ThisWorkbook.Path & "\*.xls*")

Set all_sht = Worksheets("汇总")

column_arr = all_sht.Range("xfd3").End(xlToLeft).Column

ReDim arr(1 To 1000, 1 To column_arr)

want_sht_name = all_sht.Range("b1").Value

If want_sht_name = "" Then

MsgBox "请输入“要取数据的工作表名” "

Exit Sub

End If

'MsgBox column_arr

s = 0

Do While myfile <> ""

If ThisWorkbook.Name <> myfile Then

s = s + 1

Set wb = GetObject(ThisWorkbook.Path & "\" & myfile)

For Each SHT In wb.Worksheets

If SHT.Name = want_sht_name Then

arr(s, 1) = myfile '序号

With SHT

'MsgBox SHT.Name

For i = 2 To column_arr

arr(s, i) = .Range(all_sht.Cells(2, i))

Next i

End With

End If

Next

wb.Close False

Set wb = Nothing

End If

myfile = Dir

Loop

On Error GoTo 0 '结束错误捕捉

all_sht.Range("a4:y1000").ClearComments

all_sht.Cells.NumberFormat = "@"

all_sht.Range("a4").Resize(s, UBound(arr, 2)) = arr

Application.DisplayAlerts = True

Application.ScreenUpdating = True

MsgBox "汇总文件数为：" & s & Chr(10) & "时间为：" & Timer - t

Exit Sub

'Err_Handle:

'MsgBox "读不了的错误文件为：" & myfile & Chr(10) & "移到其他文件夹，再运行！"

End Sub

==【使用方法】===

把要取得的工作表名:“Sheet1”

要取的数据所在的单元格：如B2 D2 F2……

填写在汇总表中：如下

===【运行~~成功】===