Automate the merge of 2 sheets

Simple enough question.

See attached.

I have 3 sheets containing animal names (!) in column "A".

How do I automate this so that my fourth sheet contains ALL the animals in the previous 3 sheets.
First animal in cell A1, second in A2 etc

Thanks!
AUtomateMerge.xlsm
Patrick O'DeaAsked:
Who is Participating?
 
nutschConnect With a Mentor Commented:
1. If you have headers, change the bolTitles parameters to True, as in

Set shtDone = shtConsolidateSheets(bolTitles:=True, _
                                        strSummary:="All", _
                                        bolTab:=False, _
                                        strTabTitle:="Month", _
                                        sFirstCell:="A1", _
                                        bSelectedOnly:=True)

Your sample data didn't have a title so I coded accordingly.

2. I wrote it, and I trust it fully for its limited purpose. Watch out for empty rows and columns. The macro works off of the Currentregion to find out what to copy, so if you have a fully empty column or row in the middle of your data, it will not extend past the gap.

Thomas
0
 
Rob HensonFinance AnalystCommented:
Assuming that your scenario is actually bigger than this, have you tried the "Multiple Consolidated Range" option of Pivot table?

Thanks
Rob H
0
 
nutschCommented:
Run the attached ConsolidateSheets macro after selecting the sheets you want to consolidate and it should to just fine.

Sub ConsolidateSheets()
Dim sht As Worksheet, shtDone As Worksheet


Set shtDone = shtConsolidateSheets(bolTitles:=False, _
                                        strSummary:="All", _
                                        bolTab:=False, _
                                        strTabTitle:="Month", _
                                        sFirstCell:="A1", _
                                        bSelectedOnly:=True)
End Sub


Function shtConsolidateSheets(Optional sRangeToInclude As String = "", _
                            Optional bolTitles As Boolean = True, _
                            Optional strSummary As String = "All", _
                            Optional bolTab As Boolean = False, _
                            Optional strTabTitle As String = "BU", _
                            Optional sFirstCell As String = "A1", _
                            Optional bSelectedOnly As Boolean = False, _
                            Optional sAdditionalCells As String = "", _
                            Optional lLastCol As Long = 0, _
                            Optional lLastColOffset As Long = 0) As Worksheet

Dim shtDone As Worksheet, lLastRow As Long, rgLoop As range, rgCellsToInclude As range
Dim shtLoop As Worksheet, firstSheet As Boolean, lColOffset As Long, lColLoop As Long
Dim lgTabCol As Long, lIncrement As Long, sSelectedSheets As String
Dim arrSheets As Variant, lLoop As Long, rgAddtlCells As range

'Const bolTitles As Boolean = True 'True if sheets have titles, false if they don't
'Const strSummary As String = "All" ' update to the name of the consolidated destination
'Const bolTab As Boolean = True 'get data from tab name ? True / False
'Const strTabTitle As String = "BU" 'title of column from tab name if bolTab=true
'Const sFirstCell As String = "B6" 'define first cell of data to copy (based on current region)

'turn off updates to speed up code execution
With application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

For Each shtLoop In IIf(bSelectedOnly, ActiveWindow.SelectedSheets, ActiveWorkbook.Worksheets)
    sSelectedSheets = sSelectedSheets & "\" & shtLoop.Name
Next

sSelectedSheets = Mid(sSelectedSheets, 2)
arrSheets = Split(sSelectedSheets, "\")

Set shtDone = Sheets.Add(Count:=1)

On Error Resume Next
shtDone.Name = strSummary

If Err.Number <> 0 Then
    ActiveWorkbook.Sheets(strSummary).Delete
    shtDone.Name = strSummary
    Err.Clear
End If

firstSheet = True
lLastRow = 1

If Len(sAdditionalCells) > 0 Then
    Set rgAddtlCells = range(sAdditionalCells)
    If Err <> 0 Then
        Set rgAddtlCells = Nothing
        Err.Clear
    End If
End If

For lLoop = LBound(arrSheets) To UBound(arrSheets)

    Set shtLoop = Sheets(arrSheets(lLoop))
    
    'determine what range to send
    If Len(sRangeToInclude) > 0 Then
        Set rgCellsToInclude = shtLoop.range(sRangeToInclude)
        If Err <> 0 Then
            Set rgCellsToInclude = shtLoop.range(sFirstCell).CurrentRegion
            Err.Clear
        End If
    Else
        If lLastCol > 0 Then
            Set rgCellsToInclude = shtLoop.range(sFirstCell, _
                    shtLoop.Cells(Rows.Count, lLastCol).End(xlUp).Offset(, lLastColOffset))
        Else
            Set rgCellsToInclude = shtLoop.range(sFirstCell).CurrentRegion
        End If
    End If
        
    If shtLoop.Name = strSummary Then GoTo nxtSht

    If bolTitles = True And firstSheet = False Then
        
        With rgCellsToInclude
            .Offset(1).Resize(.Rows.Count - 1).Copy
            lIncrement = .Rows.Count - 1
        End With
        
        With shtDone.Cells(lLastRow + 1, 1 + lColOffset)
            .PasteSpecial Paste:=xlValues
            .PasteSpecial Paste:=xlFormats
        End With

    Else
        
        With rgCellsToInclude
            .Copy
            lIncrement = .Rows.Count
        End With
        
        With shtDone.Cells(lLastRow + IIf(bolTitles, 1, 0), 1 + lColOffset)
            .PasteSpecial Paste:=xlValues
            .PasteSpecial Paste:=xlFormats
        End With
        
        If bolTab = True And firstSheet = True Then
            shtDone.Cells(2, lColOffset + 1) = strTabTitle
            shtDone.Cells(lLastRow, lColLoop).Resize(lIncrement) = shtLoop.Name
        End If
        
    End If
    
    If bolTab = True Then
        shtDone.Cells(lLastRow, rgCellsToInclude.Columns.Count + 1).Resize(rgCellsToInclude.Rows.Count) = shtLoop.Name
    End If
    
    If Not rgAddtlCells Is Nothing Then
        lColLoop = rgCellsToInclude.Columns.Count + IIf(bolTab, 2, 1)
        For Each rgLoop In shtLoop.range(sAdditionalCells).Cells
            shtDone.Cells(lLastRow + 1, lColLoop).Resize(lIncrement) = rgLoop.Value
            lColLoop = lColLoop + 1
        Next rgLoop
    End If
        
    firstSheet = False
    
    lLastRow = lLastRow + lIncrement

nxtSht:
Next lLoop

With application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With


Set shtConsolidateSheets = shtDone
End Function

Open in new window

0
Cloud Class® Course: C++ 11 Fundamentals

This course will introduce you to C++ 11 and teach you about syntax fundamentals.

 
Patrick O'DeaAuthor Commented:
nutsch,

How do I select the sheets to be merged?
Lets say there were 3 sheets , Sheet1, Sheet2, Sheet3.
0
 
Patrick O'DeaAuthor Commented:
Actually my last question is open to ALL!

(Just in case nutsch is not here today!)

How do I select the sheets to be merged?
Lets say there were 3 sheets , Sheet1, Sheet2, Sheet3.
0
 
nutschCommented:
Select the first sheet, hold SHIFT and select the last sheet in the group.

If they're not next to each other, select the first sheet, then hold CTRL as you select the other sheets.

Thomas
0
 
Patrick O'DeaAuthor Commented:
Thanks Thomas,

That works a treat!

A couple of questions before I close off the question.

1. Is it possible to supress the headers (which are repeated for every sheet).  I guess I dont want the first row of each sheet - except perhaps the first

2. How familiar are you with this utility? How much do you trust it?

Thanks again.
0
 
Patrick O'DeaAuthor Commented:
Superb!

Worth a lot more than the 500 points!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.