Combine Sheet with headings in different order

[olympiac]

Here is my query

Sheet A has got 30 columns
Sheet B has got same headings than Sheet A but in a different order.
Is it possible to combine both sheets without having to manipulate the order of the columns?
The code below combine 2 sheets that have got the same headings in the same order. Is the re away to modify it without adding lines of extra code to rearrange the columns?

Sub Combine()
    Dim J As Integer
    On Error Resume Next
    Sheets(1).Select
    Worksheets.Add ' add a sheet in first place
    Sheets(1).Name = "Combined"
    ' copy headings
    Sheets(2).Activate
    Range("A1").EntireRow.Select
    Selection.Copy Destination:=Sheets(1).Range("A1")
    ' work through sheets
    For J = 2 To Sheets.Count ' from sheet 2 to last sheet
        Sheets(J).Activate ' make the sheet active
        Range("A1").Select
        Selection.CurrentRegion.Select ' select all cells in this sheets
        ' select all lines except title
        Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select
        ' copy cells selected in the new sheet on last line
        Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)
    Next
End Sub
[\code]

 

[Norie]

Do you want to copy the data from one worksheet to another, placing underneath the data with the same header?

eg Sheet1, column A has the heading 'Name',Sheet2, column D 'Name' copy data from column D sheet 2 below existing data in column A sheet1?

 

[olympiac]

Solved
Sub Rearange_Order()
'
Sheets("sheet1").Select
I = Sheets("sheet1").Index
Sheets.Add
Sheets(I).Name = "New"
Last_Col_Fixed = Sheets("Sheet2").Range("IV1").End(xlToLeft).Column
Last_Col_Variable = Sheets("Sheet1").Range("IV1").End(xlToLeft).Column
I_Col_New = 1
For I = 1 To Last_Col_Fixed
Search_Header = Sheets("Sheet2").Cells(1, I)
Sheets("sheet1").Select
Set C = Range(Cells(1, 1), Cells(1, Last_Col_Variable)).Find(Search_Header, LookIn:=xlValues)
If (Not (C) Is Nothing) Then
Cells(1, C.Column).EntireColumn.Copy Sheets("New").Cells(1, I_Col_New)
I_Col_New = I_Col_New + 1
End If
Next I
End Sub

 

[olympiac]

The that I have just posted add an extra sheet.
I just need to combine both file now.

I am going to try

 

[Norie]

Well I wrote this so I may as well post it

It uses Sheet1 as the destination and Sheet2 as the source, both with headers in row 1.

Option Explicit
 
Sub MoveDataByHeader()
Dim wsDst As Worksheet
Dim wsSrc As Worksheet
Dim rngHdr As Range
Dim rngFnd As Range
Dim LastRowSrc As Long
Dim NextRowDst As Long
 
    Set wsDst = Worksheets("Sheet1")
    Set wsSrc = Worksheets("Sheet2")
    
    Set rngHdr = wsDst.Range("A1")
    
    While rngHdr.Value <> ""
 
        Set rngFnd = wsSrc.Range("1:1").Find(What:=rngHdr.Value)
        
        If rngFnd Is Nothing Then
        
            MsgBox rngHdr.Value & " header not found in source data"
            
        Else
        
            NextRowDst = wsDst.Cells(Rows.Count, rngHdr.Column).End(xlUp).row + 1
            LastRowSrc = wsSrc.Cells(Rows.Count, rngFnd.Column).End(xlUp).row + 1
            
            
            wsSrc.Cells(2, rngFnd.Column).Resize(LastRowSrc - 1).Copy wsDst.Cells(NextRowDst, rngHdr.Column)
        End If
        
        Set rngHdr = rngHdr.Offset(, 1)
    
    Wend
 
End Sub

 

[olympiac]

Nothing Happens when I run the code. Why?

 

[olympiac]

Sorry. My mistake.
The code works perfectly.

Thank you very much

 

[Norie]

Well it works for me with 2 sets of data one in Sheet1 and the other in Sheet2.

They also have matching headers but not in the same order.

 

[olympiac]

I double checked, some data ends up in another column where the heading in similar than the other one.