Excel Combine Multiple worksheets into one

Bob Tian
Bob Tian used Ask the Experts™
on
I am having trouble combining 200+ worksheets into one sheet. I have attached a sample file to show the data, and what it should look like. There is a sheet called Template to show what every sheet looks like, they are all in the same format, but not every information is filled. I added two sample data sheets called, '3M ESPE Retraction Capsule' and 'Acupeds'. The sheet called 'Final' shows what it should look like after those two sheets are combined into 'Final'. I need some help for combining multiple sheets (200+ sheets). Is there a macro to do this so I don't have to do it manually?
Book1.xlsm
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
Professor JMicrosoft Excel Expert
Top Expert 2014

Commented:
I personally don't think you can find a better and easier solution other than free Addin by Ron , you can download from here http://www.rondebruin.nl/win/addins/rdbmerge.htm

If this does not help you then you can come back and we will try to help you

Author

Commented:
I dont think this will work, as the my original templates' headers are not in columns, and I want to put this in columns as well.

Author

Commented:
Still looking for some help on this
Ensure you’re charging the right price for your IT

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden using our free interactive tool and use it to determine the right price for your IT services. Start calculating Now!

Managing Director/Excel VBA Developer
Distinguished Expert 2018
Commented:
Hi Bob,

I have edited Ron de Bruin's code as per your requirement:

Sub CombineSheets()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long

With Application
    .ScreenUpdating = False
    .DisplayStatusBar = True
    .StatusBar = "!!! Please Be Patient...Updating Records !!!"
    .EnableEvents = False
    .Calculation = xlManual
End With

'Delete the sheet "Consolidate" if it exist
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Worksheets("Consolidate").Delete
On Error GoTo 0
Application.DisplayAlerts = True

'Add a worksheet with the name "Consolidate"
Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Consolidate"

'Set Up Headers
DestSh.Cells(1, 4).Value = "Date Submitted/Requested"
DestSh.Cells(1, 5).Value = "CR#"
DestSh.Cells(1, 6).Value = "Submitted/Requested by"
DestSh.Cells(1, 7).Value = "Issue"
DestSh.Cells(1, 10).Value = "Generic Name"
DestSh.Cells(1, 11).Value = "CAS #"
DestSh.Cells(1, 12).Value = "Trade Name(s)"
DestSh.Cells(1, 13).Value = "Product Description"
DestSh.Cells(1, 16).Value = "Active Ingredient(s)"
DestSh.Cells(1, 18).Value = "Non-medicinal Ingredient(s)/excipient(s)"
DestSh.Cells(1, 19).Value = "Specific Indication(s)"
DestSh.Cells(1, 22).Value = "Marketed For/ Intended Use"
DestSh.Cells(1, 25).Value = "Instructions for Use"
DestSh.Cells(1, 28).Value = "Combination Product?"
DestSh.Cells(1, 29).Value = "Combination Product Components"
DestSh.Cells(1, 31).Value = "Principal Mechanism of Action"
DestSh.Cells(1, 34).Value = "Current Market Status"
DestSh.Cells(1, 35).Value = "Classification Outside of Canada"
DestSh.Cells(1, 36).Value = "Similar Product(s)"
DestSh.Cells(1, 37).Value = "Manufacturer"
DestSh.Cells(1, 38).Value = "Sponsor"
DestSh.Cells(1, 39).Value = "Sponsor's Contact information"
DestSh.Cells(1, 40).Value = "Sponsor's Proposal and Rationale"
DestSh.Cells(1, 43).Value = "Similar Past Decision(s)/precedent(s)"
DestSh.Cells(1, 46).Value = "Legal Opinion(s)"
DestSh.Cells(1, 49).Value = "Others Consulted"
DestSh.Cells(1, 52).Value = "Research & Analysis"
DestSh.Cells(1, 55).Value = "OoS Recommendation(s)"
DestSh.Cells(1, 58).Value = "TPCC Recommendation(s)"
DestSh.Cells(1, 61).Value = "Other Recommendation(s)"
DestSh.Cells(1, 64).Value = "CPC Recommendation(s)"
DestSh.Cells(1, 67).Value = "Impact of Decision(s)"
DestSh.Cells(1, 70).Value = "Comments"
DestSh.Cells(1, 73).Value = "Pending Action(s)"
DestSh.Cells(1, 76).Value = "Completed Action(s)"

'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets
        If IsError(Application.Match(sh.Name, Array(DestSh.Name, "Final", "Template"), 0)) Then
            'Find the last Column with data on the DestSh
            Last = LastRow(DestSh)
                sh.Range("B7").Copy
                DestSh.Cells(Last + 1, "D").PasteSpecial xlPasteValues 'Date Submitted/Requested
                sh.Range("C7").Copy
                DestSh.Cells(Last + 1, "E").PasteSpecial xlPasteValues 'CR#
                sh.Range("D7").Copy
                DestSh.Cells(Last + 1, "F").PasteSpecial xlPasteValues 'Submitted/Requested by
                sh.Range("B10").Copy
                DestSh.Cells(Last + 1, "G").PasteSpecial xlPasteValues 'Issue
                sh.Range("B14").Copy
                DestSh.Cells(Last + 1, "J").PasteSpecial xlPasteValues 'Generic Name
                sh.Range("C14").Copy
                DestSh.Cells(Last + 1, "K").PasteSpecial xlPasteValues 'CAS #
                sh.Range("D14").Copy
                DestSh.Cells(Last + 1, "L").PasteSpecial xlPasteValues 'Trade Name(s)
                sh.Range("B17").Copy
                DestSh.Cells(Last + 1, "M").PasteSpecial xlPasteValues 'Product Description
                sh.Range("B20").Copy
                DestSh.Cells(Last + 1, "P").PasteSpecial xlPasteValues 'Active Ingredient(s)
                sh.Range("D20").Copy
                DestSh.Cells(Last + 1, "R").PasteSpecial xlPasteValues 'Non-medicinal Ingredient(s)/excipient(s)
                sh.Range("B23").Copy
                DestSh.Cells(Last + 1, "S").PasteSpecial xlPasteValues 'Specific Indication(s)
                sh.Range("B26").Copy
                DestSh.Cells(Last + 1, "V").PasteSpecial xlPasteValues 'Marketed For/ Intended Use
                sh.Range("B29").Copy
                DestSh.Cells(Last + 1, "Y").PasteSpecial xlPasteValues 'Instructions for Use
                sh.Range("B32").Copy
                DestSh.Cells(Last + 1, "AB").PasteSpecial xlPasteValues 'Combination Product?
                sh.Range("C32").Copy
                DestSh.Cells(Last + 1, "AC").PasteSpecial xlPasteValues 'Combination Product Components
                sh.Range("B32").Copy
                DestSh.Cells(Last + 1, "AE").PasteSpecial xlPasteValues 'Principal Mechanism of Action
                sh.Range("B38").Copy
                DestSh.Cells(Last + 1, "AH").PasteSpecial xlPasteValues 'Current Market Status
                sh.Range("C38").Copy
                DestSh.Cells(Last + 1, "AI").PasteSpecial xlPasteValues 'Classification Outside of Canada
                sh.Range("D38").Copy
                DestSh.Cells(Last + 1, "AJ").PasteSpecial xlPasteValues 'Similar Product(s)
                sh.Range("B42").Copy
                DestSh.Cells(Last + 1, "AK").PasteSpecial xlPasteValues 'Manufacturer
                sh.Range("C42").Copy
                DestSh.Cells(Last + 1, "AL").PasteSpecial xlPasteValues 'Sponsor
                sh.Range("D42").Copy
                DestSh.Cells(Last + 1, "AM").PasteSpecial xlPasteValues 'Sponsor's Contact information
                sh.Range("B42").Copy
                DestSh.Cells(Last + 1, "AO").PasteSpecial xlPasteValues 'Sponsor's Proposal and Rationale
                sh.Range("B50").Copy
                DestSh.Cells(Last + 1, "AQ").PasteSpecial xlPasteValues 'Similar Past Decision(s)/precedent(s)
                sh.Range("B53").Copy
                DestSh.Cells(Last + 1, "AT").PasteSpecial xlPasteValues 'Legal Opinion(s)
                sh.Range("B56").Copy
                DestSh.Cells(Last + 1, "AW").PasteSpecial xlPasteValues 'Others Consulted
                sh.Range("B59").Copy
                DestSh.Cells(Last + 1, "AZ").PasteSpecial xlPasteValues 'Research & Analysis
                sh.Range("B62").Copy
                DestSh.Cells(Last + 1, "BC").PasteSpecial xlPasteValues 'OoS Recommendation(s)
                sh.Range("B65").Copy
                DestSh.Cells(Last + 1, "BF").PasteSpecial xlPasteValues 'TPCC Recommendation(s)
                sh.Range("B68").Copy
                DestSh.Cells(Last + 1, "BI").PasteSpecial xlPasteValues 'Other Recommendation(s)
                sh.Range("B71").Copy
                DestSh.Cells(Last + 1, "BL").PasteSpecial xlPasteValues 'CPC Recommendation(s)
                sh.Range("B74").Copy
                DestSh.Cells(Last + 1, "BO").PasteSpecial xlPasteValues 'Impact of Decision(s)
                sh.Range("B78").Copy
                DestSh.Cells(Last + 1, "BR").PasteSpecial xlPasteValues 'Comments
                sh.Range("B81").Copy
                DestSh.Cells(Last + 1, "BU").PasteSpecial xlPasteValues 'Pending Action(s)
                sh.Range("B84").Copy
                DestSh.Cells(Last + 1, "BX").PasteSpecial xlPasteValues 'Completed Action(s)
                Application.CutCopyMode = False
                'Optional: This will copy the sheet name in the H column
                DestSh.Cells(Last + 1, "A").Value = sh.Name
        End If
    Next

ExitTheSub:

Application.Goto DestSh.Cells(1)

'AutoFit the column width in the DestSh sheet
DestSh.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .DisplayStatusBar = True
    .StatusBar = False
    .EnableEvents = True
    .Calculation = xlAutomatic
End With

End Sub
Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("D1"), _
                            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("D1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

Open in new window


I  tested on your sample workbook and its copying all the data from every sheet to Consolidate sheet. Sorry to say Formatting cannot be pasted as it differs from every sheet to your final sheet.

You need to create separate code for formatting...
Open attached and run macro CombineSheets
Bob_Combine-Multiple-Sheet-To-One_v.xlsm

Author

Commented:
Thanks for that, it worked! I was busy with something else so I didn't have time to test it immediately
ShumsManaging Director/Excel VBA Developer
Distinguished Expert 2018

Commented:
You're Welcome Bob! Glad I was able to help.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial