View Full Version : [SOLVED:] Combine Worksheets into One Master

Anne Troy
06-16-2004, 10:52 PM
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
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, _
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, _
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
06-17-2004, 12:20 AM
Works good. :) I vote for 2 seperate entries ;)

06-19-2004, 01:15 AM
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
06-19-2004, 11:09 AM
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.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
End Sub


10-29-2008, 02:12 AM
Hi ken,

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