Patrick O'Dea
asked on
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
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
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
ASKER
nutsch,
How do I select the sheets to be merged?
Lets say there were 3 sheets , Sheet1, Sheet2, Sheet3.
How do I select the sheets to be merged?
Lets say there were 3 sheets , Sheet1, Sheet2, Sheet3.
ASKER
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.
(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.
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
If they're not next to each other, select the first sheet, then hold CTRL as you select the other sheets.
Thomas
ASKER
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.
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.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Superb!
Worth a lot more than the 500 points!
Worth a lot more than the 500 points!
Thanks
Rob H