Option Explicit
Sub CombineSheetsFromAllFilesInADirectory()
Dim Path As String
Dim FileName As String
Dim tWB As Workbook
Dim tWS As Worksheet
Dim mWB As Workbook
Dim aWS As Worksheet
Dim RowCount As Long
Dim uRange As Range
Path = ThisWorkbook.Path & "\subdirectory\"
Application.EnableEvents = False
Application.ScreenUpdating = False
Set mWB = Workbooks.Add(1)
Set aWS = mWB.ActiveSheet
If Right(Path, 1) <> Application.PathSeparator Then
Path = Path & Application.PathSeparator
End If
FileName = Dir(Path & "*.xls", vbNormal)
Do Until FileName = ""
If Path <> ThisWorkbook.Path Or FileName <> ThisWorkbook.Name Then
Set tWB = Workbooks.Open(FileName:=Path & FileName)
For Each tWS In tWB.Worksheets
Set uRange = tWS.Range("A2", tWS.Cells(tWS.UsedRange.Row + tWS.UsedRange.Rows _
.Count - 1, tWS.UsedRange.Column + tWS.UsedRange.Columns.Count - 1))
If RowCount + uRange.Rows.Count > 65536 Then
aWS.Columns.AutoFit
Set aWS = mWB.Sheets.Add(After:=aWS)
RowCount = 0
End If
If RowCount = 0 Then
aWS.Range("A1", aWS.Cells(1, uRange.Columns.Count)).Value = _
tWS.Range("A1", tWS.Cells(1, uRange.Columns.Count)).Value
RowCount = 1
End If
aWS.Range("A" & RowCount + 1).Resize(uRange.Rows.Count, uRange.Columns.Count).Value _
= uRange.Value
RowCount = RowCount + uRange.Rows.Count
Next
tWB.Close False
End If
FileName = Dir()
Loop
aWS.Columns.AutoFit
mWB.Sheets(1).Select
Application.EnableEvents = True
Application.ScreenUpdating = True
Set tWB = Nothing
Set tWS = Nothing
Set mWB = Nothing
Set aWS = Nothing
Set uRange = Nothing
End Sub
|