|
Sub 合并()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set ww = ThisWorkbook
For Each sh In Sheets
If sh.Index > 1 Then
sh.Delete
End If
Next sh
f = Dir(ThisWorkbook.Path & "\*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
m = m + 1
For Each sht In wb.Worksheets
If sht.Index <> 3 Then
If sht.Index = 1 Then
ks = 6
Else
ks = 4
End If
r = sht.Cells(sht.Rows.Count, 2).End(xlUp).Row + 1
rs = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
If m = 1 Then
sht.Copy after:=ww.Worksheets(ww.Worksheets.Count)
With ww.Worksheets(ww.Worksheets.Count)
If rs > r Then .Rows(r & ":" & rs).Delete
End With
Else
With ww.Worksheets(sht.Name)
ws = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
sht.Rows(ks & ":" & r).Copy .Cells(ws, 1)
End With
End If
End If
Next sht
wb.Close False
End If
f = Dir
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|