Merging Worksheets with different headers

[pglove]

Windows 7 x64
Excel 2007

I have scoured the internet for a quick solution to this problem, there are many questions that seem to ask the same thing I require but no answers I can see.

Microsoft knowledge base is useful, but unfortunately I can't seem to find a solution that applies to this particular case. Same with MrExcel, so if there is a thread I've missed that'll make my century!

_____

I have 18 workbooks
Each workbook has up to 22 worksheets
~ 400 worksheets total
Each worksheet has about 400 rows of data and anything from 6-58 columns
~160,000 rows of data total

As is probably clear from the fact that the number of columns varies, not all of the headers are consistent - but many are commonly occuring.

I found the consolidate tool, and this had the potential to make my task very simple, but the problem I have is it doesn't appear to have the option to simply append data.

For example, the simplest worksheet has headers:

Supplier (common to all - fixed position, Column A, repeating values)
Date (common to all - moves, repeating values)
Qty (common to all - moves, repeating values)
Low (common to all - moves, repeating values)
High (common to all - moves, repeating values)
Renew (only present in the very old worksheets but I wish to retain this column)


The most complicated has:

Supplier
ContactName
Tel1
Tel2
Add1
Add2
Add3
Add4
Add5
Added
LastActivity
Date
Qty
Low
High
RandomA (occassionally repeating values, not always present)
RandomB (occassionally repeating values, not always present)
...
(and more)


I need to combine these many worksheets so that ALL headers from ALL sheets are present in the consolidated worksheet and that the matching columns are appended into one huge worksheet.

Thankfully Excel 2007 allows more than 65536 rows so I assume this is possible, I just need a way to use the consolidate function to do what it does without performing any calculations... or an alternative solution.

Excel 2007 seems very powerful and much easier to use. I hope this is doable without resorting to complex macros as the time it would take to code all the different variables for column headers etc. would probably take as long as cutting and pasting manually.

Praying for some replies

 

[mikester]

Works for me but does anyone know why the macro is converting some worksheets dates from DD/MM/YYYY to MM/DD/YYYY in the resulting product? Only happens to some sheets, not all...

 

[Riri45h]

Copy/Paste the code below to a workbook's standard code-module. Run it.
It will create a new sheet in that workbook to receive the merged data. It will ask you to (multi-)select the files you want to process. Then it will takes those files, one at a time and:

open it​

run through all the sheets in that file, one at a time and:​

go through all the headers in row 1 of that sheet​

if it's a new header, add it to the destination sheet​

copy data from that column to the destination sheet appropriate column​

​

close the file (without saving)​

​

It will fail if on any sheet there's no cells with text on row 1.

Because it uses the 'usedrange' of each sheet, which is not always the actual used range (it's often bigger than the actual used range) you may find a number of blank rows in the resultant new sheet.
The left to right order of headers is solely dependant on the order of headers as they're found on the sheets examined. You can sort the resultant sheet horizontally to get similar headers adjacent.
Good luck.

Sub blah()
Dim rngHdr As Range, HdrsToCopy As Range, DestRow As Range
Dim AllHeaders()
ReDim AllHeaders(0 To 0)
With ThisWorkbook
  Set DestSheet = .Sheets.Add(after:=.Sheets(.Sheets.Count))
End With  'thisworkbook
With DestSheet
  Set DestRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)  'or any other column.
End With  'DestSheet
filenames = Application.GetOpenFilename("Excel files,*.xls*", MultiSelect:=True)
If IsArray(filenames) Then
  For Each fName In filenames
    Set WkBk = Workbooks.Open(fName)
    For Each sht In WkBk.Sheets
      rowscount = sht.UsedRange.Rows.Count - 1
      For Each cll In sht.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Cells
        NewHeader = False
        HeaderColumn = 0
        For i = LBound(AllHeaders) To UBound(AllHeaders)
          If AllHeaders(i) = cll.Value Then
            HeaderColumn = i
            Exit For
          End If
        Next i
        If HeaderColumn = 0 Then
          If UBound(AllHeaders) = 0 Then ReDim AllHeaders(1 To UBound(AllHeaders) + 1) Else ReDim Preserve AllHeaders(1 To UBound(AllHeaders) + 1)
          AllHeaders(UBound(AllHeaders)) = cll.Value
          HeaderColumn = UBound(AllHeaders)
          NewHeader = True
        End If
        If NewHeader Then DestSheet.Cells(1, HeaderColumn).Value = AllHeaders(HeaderColumn)
        cll.Offset(1).Resize(rowscount).copy DestRow.Offset(, HeaderColumn - 1)
      Next cll
      Set DestRow = DestRow.Offset(rowscount)
    Next sht
    WkBk.Close False
  Next fName
End If
End Sub

ps.
re:Shouldn't be a problem.

OMG, you saved my life with this code, thank you!