How to copy multiple sheets to a master sheet using distinct column headers

Question

I am trying to create vba to consolidate multiple sheets into a single master sheet by matching Column Headers. I have found multiple threads and documents from microsoft but I'm still coming up short. I have grabbed alot from other users and added my needed twist. Here is what I have...

Option Compare Text

Sub cc()

    Dim Sheet As Worksheet
    Dim DestSheet As Worksheet
    Dim Last As Long
    Dim SheetLast As Long
    Dim CopyRange As Range
    Dim StartRow As Long

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set DestSheet = Sheet("Database_Headers")
    StartRow = 2

    For Each Sheet In ActiveWorkbook.Worksheets
        If LCase(Left(Sheet.Name, 6)) = "Demand" Then

            Last = DestSheet.Cells(Rows.Count, "A").End(xlUp).Row
            SheetLast = Sheet.Cells(Rows.Count, "A").End(xlUp).Row

            If SheetLast > 0 And SheetLast >= StartRow Then

                Sheet.Select
                Region_Name = WorksheetFunction.Match("Region Name", Rows("1:1"), 0)
                location_code = WorksheetFunction.Match("location_code", Rows("1:1"), 0)
                location_name = WorksheetFunction.Match("location_name", Rows("1:1"), 0)
                dealer_code = WorksheetFunction.Match("dealer_code", Rows("1:1"), 0)

                Sheet.Columns(Region_Name).Copy Destination:=DestSheet.Range("C" & Last + 1)
                Sheet.Columns(location_code).Copy Destination:=DestSheet.Range("D" & Last + 1)
                Sheet.Columns(location_name).Copy Destination:=DestSheet.Range("E" & Last + 1)
                Sheet.Columns(dealer_code).Copy Destination:=DestSheet.Range("F" & Last + 1)

            End If

        End If

        CopyRange.Copy

        With DestSheet.Cells(Last + 1, "C")

        End With

        DestSheet.Cells(Last + 1, "B").Resize(CopyRng.Rows.Count).Value = Sheet.Name

    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub

My Current error is coming from:

Set DestSheet = Sheet("Database_Headers") 

but I am not sure if I am needing to clarify further or if I need to add a further clarifying line.

Thank you all in advance for any help!!!

EDIT UPDATE

I have updated the code to: Option Compare Text

Sub cc()

Dim Sh As Worksheet
Dim DestSheet As Worksheet
Dim Last As Long
Dim SheetLast As Long
'Dim CopyRange As Range
Dim StartRow As Long

'Disables screen updates so screen does not flicker when code is running
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With

'Clarify the summary tab
Set DestSheet = Worksheets("Database_Headers")


    ' Will not copy column headers and will only copy data
    StartRow = 2

        'Will copy all data from each sheet that has a different name then the summary tab
        For Each Sh In ActiveWorkbook.Worksheets
        If LCase(Left(Sh.Name, 6)) = "Demand" Then

            Last = DestSheet.Cells(Rows.Count, "B").End(xlUp).Row
            shLast = Sh.Cells(Rows.Count, "A").End(xlUp).Row

            If shLast > 0 And shLast >= StartRow Then

            `Set CopyRange = Sh.Select`
                Region_Name = WorksheetFunction.Match("Region Name", Rows("1:1"), 0)
                location_code = WorksheetFunction.Match("location_code", Rows("1:1"), 0)
                location_name = WorksheetFunction.Match("location_name", Rows("1:1"), 0)
                dealer_code = WorksheetFunction.Match("dealer_code", Rows("1:1"), 0)

                Sh.Columns(Region_Name).Copy Destination:=DestSheet.Range("B" & Last + 1)
                Sh.Columns(location_code).Copy Destination:=DestSheet.Range("C" & Last + 1)
                Sh.Columns(location_name).Copy Destination:=DestSheet.Range("D" & Last + 1)
                Sh.Columns(dealer_code).Copy Destination:=DestSheet.Range("E" & Last + 1)

            End If

      End If

    `CopyRange.Copy`

    With DestSheet.Cells(Last + 1, "B")
    End With

    DestSheet.Cells(Last + 1, "A").Resize(CopyRange.Rows.Count).Value = Sh.Name

Next

ExitTheSub:

Application.Goto DestSheet.Cells(1)

' AutoFit the column width in the summary sheet.
DestSheet.Columns.AutoFit

With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

End Sub

I am seeing another error in regards to my copy range function. I am wanting the vba to go sheet by and and only copy the data under the column headers that match what is in the master. Thanks for the help!!

Answer 1

Your error is in the fact that you do not refer to the Sheets collection properly. It should be done like this:

Set DestSheet = Sheets("Database_Headers")

However, in this case, you should not refer to the Sheets collection, but to the Worksheets collection, because you have declared DestSheet as a Worksheet and thus you can avoid some problems later. Thus like this:

Set DestSheet = Worksheets("Database_Headers")

In general, this is the difference between a Worsheet and a Sheet (and the corresponding collections) - create an empty Excel and add a chart sheet as a separate Sheet. Then run the following code:

Public Sub TestMe()
    Debug.Print Worksheets.Count
    Debug.Print Sheets.Count
End Sub

It would give 3 and 4 - you have 3 Excel Worksheets and 4 Sheets (the chart sheet is a sheet).

Here is a problem, that would be avoided if you use it correctly - VBA Refer to worksheet vs chart sheet

Answer 2

Yes, I loaded your code in and got the same error. It's because you have

Set DestSheet = Sheet("Database_Headers")

but you should have

Set DestSheet = Sheets("Database_Headers")

After that you'll have to deal with other errors such as

For Each Sheet...

Where you haven't defined "Sheet" as a variable (use something other than "Sheet" since that's a reserved word -- perhaps "sh" Here's some code to start you off -- I didn't have enough info to really complete it, but you might find it helpful

Option Explicit
Sub cc()
Dim sh As Worksheet, destSh As Worksheet
Dim s As String, r As Range, i As Integer, j As Integer

Set destSh = Sheets("Database_Headers")
Set destRange = destSh.Range("A1")
For Each sh In Worksheets
  If LCase(Left(Sheet.Name, 6)) = "Demand" Then
    Set r = sh.Range("A1")
    Set r = Range(r, r.End(xlDown))
    For i = 0 To r.Row.Count
      s = r.Offset(i, 0).Value
      If InStr(s, "desired text") Then
        'transferedData = ...
      End If
    Next i
  End If
  'transfer data to destSh
  destRange.Offset(j, 0) = transferedData
  j = j + 1
Next sh

End Sub