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

 

[ruby20]

The code begins with no headers on the destination sheet, and adds headers as it finds them in row 1 of the source sheets as it runs through them.
If the first source sheet only has 2 headers, then the destination sheet gets those 2 (new) headers added to it, if the second sheet has more headers, it only adds the ones that are different (new) to the destination sheet, etc.

My question in msg#16 still needs answering.[/QUOT

RE: Msg #16

If the first and second source sheet have headers that are equal the merge would join those columns and stack them one on top of the other in the destination sheet. When I said "the same" I meant the headers from source sheets that are equal. And furthering that, how could include only headers that are on both source sheets(providing you open more than one).

I hope I explained that clearly?

 

[p45cal]

Remember that the code (a) iterates through selected workbooks (there might be 1, there might be 101), then (b) with each workbook it iterates through all its sheets (there may be 1, there may be 101). You're leaving it pretty much to chance which two sheets are going to be used to decide the columns you want copied over.

…unless you're telling me that you will only ever be looking to compare and merge two worksheets' headers, because, for example, it may be that you only intend to choose a single workbook with two sheets in, or perhaps 2 workbooks, each with a single sheet?

 

[ruby20]

Remember that the code (a) iterates through selected workbooks (there might be 1, there might be 101), then (b) with each workbook it iterates through all its sheets (there may be 1, there may be 101). You're leaving it pretty much to chance which two sheets are going to be used to decide the columns you want copied over.

…unless you're telling me that you will only ever be looking to compare and merge two worksheets' headers, because, for example, it may be that you only intend to choose a single workbook with two sheets in, or perhaps 2 workbooks, each with a single sheet?

That is Exactly what I'm doing: 2 different workbooks, each with a single sheet. And im trying to merge them by the headers that they have in common. It sounded liek a simple task but i have been racking my brain with this code!

 

[p45cal]

No bells and whistles, few checks, a bit raw:

Sub blah()
Dim DestRow As Range
Dim TwoWorkBooks(1 To 2), RowsCount(1 To 2)
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
  If UBound(filenames) = 2 Then
    For i = 1 To 2
      Set TwoWorkBooks(i) = Workbooks.Open(filenames(i))
      RowsCount(i) = TwoWorkBooks(i).Sheets(1).UsedRange.Rows.Count - 1
    Next i
    HdrCount = 0
    For Each cll In TwoWorkBooks(1).Sheets(1).Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Cells
      Set X = TwoWorkBooks(2).Sheets(1).Rows(1).Find(What:=cll.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchFormat:=False)
      If Not X Is Nothing Then
        HdrCount = HdrCount + 1
        DestSheet.Cells(1, HdrCount) = cll.Value
        cll.Offset(1).Resize(RowsCount(1)).Copy DestRow.Offset(, HdrCount - 1)
        X.Offset(1).Resize(RowsCount(2)).Copy DestRow.Offset(RowsCount(1), HdrCount - 1)
      End If
    Next cll
    For Each wkbk In TwoWorkBooks
      wkbk.Close False
    Next wkbk
  Else
    MsgBox "2 files must be selected"
  End If
End If
End Sub

 

[ruby20]

No bells and whistles, few checks, a bit raw:

Sub blah()
Dim DestRow As Range
Dim TwoWorkBooks(1 To 2), RowsCount(1 To 2)
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
  If UBound(filenames) = 2 Then
    For i = 1 To 2
      Set TwoWorkBooks(i) = Workbooks.Open(filenames(i))
      RowsCount(i) = TwoWorkBooks(i).Sheets(1).UsedRange.Rows.Count - 1
    Next i
    HdrCount = 0
    For Each cll In TwoWorkBooks(1).Sheets(1).Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Cells
      Set X = TwoWorkBooks(2).Sheets(1).Rows(1).Find(What:=cll.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchFormat:=False)
      If Not X Is Nothing Then
        HdrCount = HdrCount + 1
        DestSheet.Cells(1, HdrCount) = cll.Value
        cll.Offset(1).Resize(RowsCount(1)).Copy DestRow.Offset(, HdrCount - 1)
        X.Offset(1).Resize(RowsCount(2)).Copy DestRow.Offset(RowsCount(1), HdrCount - 1)
      End If
    Next cll
    For Each wkbk In TwoWorkBooks
      wkbk.Close False
    Next wkbk
  Else
    MsgBox "2 files must be selected"
  End If
End If
End Sub

Thank you so much, Im going to give it a run and tweak where needed but Very helpful!!

 

[ruby20]

Thank you so much, Im going to give it a run and tweak where needed but Very helpful!!

After running it I had errors such as " out of range " and something like "application or object error"
in my resulting sheet i had one header that is common in both sheets but with no data underneath it. any thoughts or suggestions?

 

[p45cal]

any thoughts or suggestions?

Sure:
Are the headers on row 1?
How are the data laid out on each sheet?
You do just choose 2 workbooks, not 3, not one..?

I had errors such as " out of range " and something like "application or object error"

These are a bit vague - if we could have the line(s) they occurred on and an accurate error message, it would be a lot easier to pinpoint the problem.

 

[Jason Chan]

Re: Merging just 3 worksheets of a single Workbook with different headers

P45cal,

hi, my problem is similar to Pglove's, except, I dont have so many workbooks, I just have one. My workbook has 3 sheets that I need to be combined into a 4th sheet, in the same manner as requested by Pglove. Some rows may intermittently be blank, because of not meeting the criteria of the IF..ELSE function in each rows I wrote inside those 3 sheets. All 3 sheets may have some common headers, and also other different ones. I need to combine all rows of 3 sheets into a 4th sheet, with all headers present, all rows present, and then autosorted continously when new data is populated into the 3 sheets.

Can you help me with the VBA code for that 4th sheet ?


Anticipation with gratitude for the Help,

Jason.

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.

 

[Culaff]

Re: Merging just 3 worksheets of a single Workbook with different headers

Sorry for the bump, but is there any way to modify this excellent code by p45cal to a single workbook. Whenever I am trying the consolidation for all the sheets in the same workbook, it is running infinitely.

Still excellent logic and cheers.

 

[DINAUKAUR]

Run Time error 1004 is throwing