Combine non unique worksheets

Question

I have a workbook with 37 tabs.

Each tab has between 37 and 60 columns each with headers and then values going down the rows.

The number of rows can vary. The current file has some tabs with as few as 17 rows and as high as 6181.

Across all tabs if you were to combine the headers and remove duplicates there are 189 different possible options.

The format of each file is the same and the desired output is the same.

I want to make a new tab called CombinedData that has all 189 possible headers and then move every row of data from all the tabs into this one with their values going into the columns based on header names.

Code that ChatGPT got me.

Sub CombineTabs()
    Dim combinedSheet As Worksheet
    Dim originalSheet As Worksheet
    Dim header As Range
    Dim targetCol As Long

    ' Create a new sheet for the combined data
    Set combinedSheet = Sheets.Add(After:=Sheets(Sheets.Count))
    combinedSheet.Name = "CombinedData"

    ' Loop through all sheets in the original workbook
    For Each originalSheet In ThisWorkbook.Sheets
        ' Loop through each header in the Summary sheet
        For Each header In originalSheet.Range("A1:BI1")
            ' Get the target column in the Combined sheet
            targetCol = targetCol + 1

            ' Copy the header to the Combined sheet
            combinedSheet.Cells(1, targetCol).Value = header.Value

            ' Copy the values from the original sheet to the Combined sheet
            Dim lastRowCombined As Long
            lastRowCombined = combinedSheet.Cells(combinedSheet.Rows.Count, targetCol).End(xlUp).Row

            combinedSheet.Cells(2, targetCol).Resize(originalSheet.UsedRange.Rows.Count - 1, 1).Value = originalSheet.Columns(header.Column).Value

            ' Remove duplicates in the Combined sheet
            lastRowCombined = combinedSheet.Cells(combinedSheet.Rows.Count, targetCol).End(xlUp).Row
            combinedSheet.Range(combinedSheet.Cells(2, targetCol), combinedSheet.Cells(lastRowCombined, targetCol)).RemoveDuplicates Columns:=1, header:=xlNo
        Next header
    Next originalSheet
End Sub

The code tries to put the tabs next to each other on the Combined Data tab and not all the data is coming over.

The end game of this project is that once in a single tab we will upload the data into a SQL database each week so that we can query the data and add it to reports/dashboards.

---

To answer some questions there are duplicate header names on any one sheet but there are duplicates when looking at different sheets.

Answer 1

• Assuming there are no duplicate header names on each sheet.

Option Explicit

Sub Demo()
    Dim i As Long, j As Long
    Dim vKey, oDic, arrData, rngData As Range
    Dim arrRes, iR As Long, iC As Long, iRes As Long
    Dim LastRow As Long, LastCol As Long, ColCnt As Long
    Dim oSht As Worksheet, cbSht As Worksheet
    Const CB_SHT = "CombinedData"
    Const MAX_COL = 60 ' modify as needed
    ' Create CombinedData sheet
    On Error Resume Next
    Set cbSht = Sheets(CB_SHT)
    On Error GoTo 0
    If cbSht Is Nothing Then
        Set cbSht = Sheets.Add
        cbSht.Name = CB_SHT
    Else
        cbSht.Cells.Clear
    End If
    Set oDic = CreateObject("scripting.dictionary")
    iR = 2
    ' loop through worksheet
    For Each oSht In Worksheets
        If oSht.Name <> CB_SHT Then
            LastRow = oSht.Cells(oSht.Rows.Count, "A").End(xlUp).Row
            If LastRow > 1 Then
                LastCol = oSht.Cells(1, oSht.Columns.Count).End(xlToLeft).Column
                Set rngData = oSht.Range("A1", oSht.Cells(LastRow, LastCol))
                arrData = rngData.Value ' load data into an array
                For j = LBound(arrData, 2) To UBound(arrData, 2)
                    If Not oDic.exists(arrData(1, j)) Then
                        oDic(arrData(1, j)) = oDic.Count + 1
                    End If
                Next
                ReDim arrRes(1 To UBound(arrData) - 1, 1 To oDic.Count)
                For j = LBound(arrData, 2) To UBound(arrData, 2)
                    iC = oDic(arrData(1, j))
                    For i = LBound(arrData) + 1 To UBound(arrData)
                        arrRes(i - 1, iC) = arrData(i, j)
                    Next
                Next
                ' Write ouput to CombinedData sheet
                cbSht.Cells(iR, 1).Resize(UBound(arrRes), oDic.Count).Value = arrRes
                iR = iR + UBound(arrRes)
            End If
        End If
    Next
    ' Populate headers
    ReDim arrRes(0, 1 To oDic.Count)
    i = 0
    For Each vKey In oDic.Keys
        i = i + 1
        arrRes(0, i) = vKey
    Next
    cbSht.Cells(1, 1).Resize(1, oDic.Count).Value = arrRes
End Sub