|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Dim arr(), s&
Sub 多簿多表合并为一表()
Dim MyPath, MyName, AWbName
Dim wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
bth = Val(Application.InputBox("请输入表头占据了的行数:", "拆分表格", "1"))
bw = Val(Application.InputBox("请输入表尾行数:", "拆分表格", "0"))
Application.ScreenUpdating = False
Application.DisplayAlerts = False
MyPath = ThisWorkbook.Path
s = 0
Zdir ThisWorkbook.Path
For Each hhl In arr
If hhl <> "" Then
MyName = Dir(hhl)
AWbName = ThisWorkbook.Name
If MyName <> AWbName And MyName <> "" Then
Set wb = Workbooks.Open(hhl)
With Workbooks(1).ActiveSheet
For G = 1 To wb.Sheets.Count
tqgzb = wb.Sheets(G).Name
lh = wb.Sheets(G).UsedRange.Columns.Count + wb.Sheets(G).UsedRange.Column - 1
hh = wb.Sheets(G).Range("a7").End(xlDown).Row
k = k + 1
If k = 1 Then
wb.Sheets(G).Range("a1").Resize(hh - bw, lh).Copy .Cells(.Range("a65536").End(xlUp).Row + n, 1)
hh1 = Workbooks(1).ActiveSheet.UsedRange.Rows.Count + Workbooks(1).ActiveSheet.UsedRange.Row - 1
n = (n + 1) ^ 0
Else
If hh > 1 Then
wb.Sheets(G).Range("a" & bth + 1).Resize(hh - bw - bth, lh).Copy .Cells(.Range("a65536").End(xlUp).Row + n, 1)
End If
n = (n + 1) ^ 0
End If
Next
wb.Close False
End With
End If
End If
Next
ActiveSheet.Name = "合并结果"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
msgbox "合并完毕!"
End Sub
Sub Zdir(P)
Set Fso = CreateObject("scripting.filesystemobject")
For Each f In Fso.GetFolder(P).Files
If f Like "*.xl*" Then
s = s + 1
ReDim Preserve arr(1 To s)
arr(s) = f
End If
Next
For Each m In Fso.GetFolder(P).SubFolders
Zdir m
Next
End Sub
|
|