Dim OK As Boolean
Sub ConsolidateWorkbook()
Dim k1 As Long, k2 As Long, n As Long
Application.ScreenUpdating = False
k1 = 1
k2 = 2
n = ActiveWorkbook.Worksheets.Count
While k2 <= n
CombineSheets Worksheets(k1), Worksheets(k2)
If OK Then
k2 = k2 + 1
Else
k1 = k1 + 1
If k2 = k1 Then k2 = k2 + 1
End If
Wend
Application.DisplayAlerts = False
For k2 = n To k1 + 1 Step -1
' Worksheets(k2).Delete
Next k2
MsgBox n & " worksheets have been consolidated to " & k1, vbOKOnly + vbInformation, "All Done"
End Sub
Sub CombineSheets(s1 As Worksheet, s2 As Worksheet)
Dim n1 As Long, n2 As Long
n1 = s1.Range("A999999").End(xlUp).Row
n2 = s2.Range("A999999").End(xlUp).Row
OK = (n1 + n2 <= 999999)
If OK Then
With s2.Range(s2.Cells(1, 1), s2.Cells(n2, s2.UsedRange.Columns.Count))
.Copy s1.Range("A" & n1 + 1)
' .Clear
End With
End If
End Subcitovat