Combine Worksheets into One Master

[Anne Troy]

Great procedure. Thanks, smozgur!

This macro takes the used range from all worksheets (we're assuming they all have the exact same layout) and combines them into a new worksheet called "Master".

I want to add it to our knowledgebase, but I think we ought to add a little message box that asks if the worksheets have heading rows, because most will, and then edit the code accordingly so that it doesn't pull the first row over in that case. Either that, or we make 2 KB entries, one for each scenario.

Here's the current code:

Sub CopyUsedRangeValues()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
If SheetExists("Master") = True Then
    MsgBox "A worksheet called Master already exists"
    Exit Sub
End If
Application.ScreenUpdating = False
Set DestSh = Worksheets.Add
DestSh.Name = "Master"
For Each sh In ThisWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then
        If sh.UsedRange.Count > 1 Then
            Last = LastRow(DestSh)
            With sh.UsedRange
                DestSh.Cells(Last + 1, 1).Resize(.Rows.Count, _
                .Columns.Count).Value = .Value
            End With
        End If
    End If
Next
Application.ScreenUpdating = True
End Sub
 
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
 
Function Lastcol(sh As Worksheet)
On Error Resume Next
Lastcol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
 
Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(Sheets(SName).Name))
End Function

Current sample attached.

[Zack Barresse]

Works good. I vote for 2 seperate entries

[roos01]

Hello Dreamboat,
I learned on an other forum from Brad that the sheetexist function would not work if the Error trapping in VBA is set to "break on all errors" (Tools>>Options>>General menu item) this function will return: #VALUE!
instead you might use a function simular like:

Function SheetExists(sname) As Boolean
' Returns TRUE if sheet exists in the active workbook
If IsError(Evaluate(sname & "!A1")) Then SheetExists = False _
Else SheetExists = True
End Function

you might even use "IV65536" instead A1 since it is not likely that someone has data in the "last" cell.

[Ken Wright]

Here's a routine I use that does the same thing, but does indeed ask for the header row. It also introduces an extra column, and then tags every set of data from each sheet with that sheets name against. This means that you don't lose sight of the granularity that the sheetname gave you. makes it nice and easy to throw into a Pivot table that way.

Sub SummaryCombineMultipleSheets() 
Dim SumWks As Worksheet
Dim sd As Worksheet
Dim sht As Long
Dim lrow1 As Long
Dim lrow2 As Long
Dim StRow As Long
HeadRow = InputBox("What row are the Sheet's data headers in?")
DataRow = HeadRow + 1
On Error Resume Next
Application.DisplayAlerts = False
Sheets("Summary Sheet").Delete
Application.DisplayAlerts = False
On Error GoTo 0
Set SumWks = Worksheets.Add
With SumWks
    .Move Before:=Sheets(1)
    .Name = "Summary Sheet"
    Sheets(2).Rows(HeadRow).Copy .Range("1:1")
    Columns("A:A").Insert Shift:=xlToRight
    Range("A1").Value = "INDEX"
End With
With Sheets(2)
    ColW = .UsedRange.Column - 1 + .UsedRange.Columns.Count
End With
For sht = 2 To ActiveWorkbook.Sheets.Count
    Set sd = Sheets(sht)
    lrow1 = SumWks.Cells(Rows.Count, "B").End(xlUp).Row
    lrow2 = sd.Cells(Rows.Count, "B").End(xlUp).Row
    sd.Activate
    sd.Range(Cells(DataRow, 1), Cells(lrow2, ColW)).Copy SumWks.Cells(lrow1 + 1, 2)
    SumWks.Cells(lrow1 + 1, 1).Resize(lrow2 - (DataRow - 1), 1).Value = sd.Name
Next sht
SumWks.Activate
End Sub

Regards
Ken......................

[jackal_yap]

Hi ken,

How if i want to use the same code on other workbook?

Rgds,
Jackal