|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Sub 合并多薄一表为一薄多表()
Application.ScreenUpdating = False
Dim ww As Workbook
Dim sh As Worksheet
Dim arr(), brr()
Dim wb As Workbook
Dim dlgOpen As FileDialog
Set ww = ThisWorkbook
lj = ThisWorkbook.Path
VBA.ChDir lj
Set dlgOpen = Application.FileDialog(msoFileDialogFolderPicker)
With dlgOpen
If .Show <> -1 Then MsgBox "您没有选择文件夹!": Exit Sub
lj = .SelectedItems(1)
End With
Application.DisplayAlerts = False
For Each sh In ww.Worksheets
If sh.Index > 1 Then sh.Delete
Next sh
Application.DisplayAlerts = True
t = Timer
f = Dir(lj & "\*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(lj & "\" & f, 0)
wb.Worksheets(1).Copy after:=ww.Worksheets(ww.Worksheets.Count)
mc = Split(wb.Name, ".")(0)
With ww.Worksheets(ww.Worksheets.Count)
.Name = mc
End With
wb.Close False
End If
f = Dir
Loop
Application.ScreenUpdating = True
MsgBox "合并完毕!耗时:" & Format(Timer - t, "0.00") & "秒", 64, "EXCEL提醒"
|
|