Excel VBA Match Columns while Pasting - excel

Question

I have small set of data in excel with 4 columns
File A:
SNO TYPE CountryA CountryB CountryD
1 T1 A1 B2 D1
2 T2 A2 B2 D2
and i have this data in another excel file
File B:
SNO TYPE CountryB CountryA CountryC
11 T10 B10 A10 C10
22 T20 B20 A20 C20
33 T30 B30 A30 C30
Now if i want to paste the data in file B over the data in file A, i want the column names to align automatically using some vba code.
So the End result should look like,
SNO TYPE CountryA CountryB CountryC CountryD
1 T1 A1 B1 -- D1
2 T2 A2 B2 -- D2
11 T10 A10 B10 C10 --
22 T20 A20 B20 C20 --
33 T30 A30 B30 C30 --

Answer 1

This should work for you:
Sub MatchUpColumnDataBasedOnHeaders()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Set ws = wbk.Sheets(1)
Set ws2 = wbk.Sheets(2)
Dim cell As Range
Dim refcell As Range
Application.ScreenUpdating = False
ws.Select
For Each cell In ws.Range("A1:Z1")
cell.Activate
ActiveCell.EntireColumn.Copy
For Each refcell In ws2.Range("A1:Z1")
If refcell.Value = cell.Value Then refcell.PasteSpecial (xlPasteValues)
Next refcell
Next cell
Application.ScreenUpdating = True
End Sub
It's funny, I have this feeling there is a really easy non-VBA way to do this - but I couldn't find the button for it on google. This will work for columns A to Z on sheets 1 and 2. This assumes your headers are in row 1.
EDIT - IN ADDITION:
I noticed that you wanted to do this with files and you didn't say anything about sheets. This is how you would do it with different workbooks:
Sub MatchUpColumnDataBasedOnHeadersInFiles()
Dim wbk As Workbook
Set wbk = ThisWorkbook
Workbooks.Open Filename:="C:\PasteIntoWorkbook.xlsx"
Set wbk2 = Workbooks("PasteIntoWorkbook.xlsx")
Set ws = wbk.Sheets(1)
Set ws2 = wbk2.Sheets(1)
Dim cell As Range
Dim refcell As Range
wbk.Activate
Application.ScreenUpdating = False
ws.Select
For Each cell In ws.Range("A1:N1")
wbk.Activate
ws.Select
cell.Activate
ActiveCell.EntireColumn.Copy
wbk2.Activate
ws2.Select
For Each refcell In ws2.Range("A1:N1")
If refcell.Value = cell.Value Then refcell.PasteSpecial (xlPasteValues)
Next refcell
Next cell
ws2.Select
Range("A1").Select
wbk.Activate
ws.Select
Range("A1").Select
Application.ScreenUpdating = True
End Sub
So if were heart-set on working with different .xls files, then that is how yo would do that. You obviously would just need to adjust the file path to whatever your paste-into file would be.

Answer 2

Match column coding
Sheet2 = Your original HEADERS ( Only required headers - Put them into row 1 )
Sheet1 = your data along with the headers but headers are not in sync which could be having more headers or less but you want your data as per the headings present in the sheet2
now put your data into sheet2 ( in row 2 ) below the headers which are already present into sheet2 and run the below coding and your data will appear as per the required headers.
Sub Rahul()
Dim Orig_Range As Range
Dim New_Range As Range
Dim ToMove As Range
Dim RowOld, RowNew As Long
Dim ColOld, ColNew As Long
Dim WSD As Worksheet
Dim Cname As String
Set WSD = ActiveSheet
ColOld = WSD.Cells(1, Application.Columns.Count).End(xlToLeft).Column
ColNew = WSD.Cells(2, Application.Columns.Count).End(xlToLeft).Column
RowNew = WSD.Cells(Application.Rows.Count, 1).End(xlUp).Row
RowOld = 1
Set Orig_Range = Range(WSD.Cells(1, 1), WSD.Cells(1, ColOld))
For i = 1 To ColOld
Set New_Range = Range(WSD.Cells(2, 1), WSD.Cells(2, ColNew))
Cname = Orig_Range.Cells(RowOld, i).Value
Set ToMove = New_Range.Find(what:=Cname, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, MatchCase:=True)
If ToMove Is Nothing Then
New_Range.Cells(1, i).Resize(RowNew, 1).Select
Selection.Insert shift:=xlToRight
ElseIf Not ToMove.Column = i Then
ToMove.Resize(RowNew, 1).Select
Selection.Cut
New_Range.Cells(1, i).Select
Selection.Insert shift:=xlToRight
End If
Next i
End Sub