Copy Column data from one sheet into another where Headers don't quite match.

blbat

Active Member
Joined
Mar 24, 2010
Messages
323
I need to force-feed five columns of data from one workbook that has 15 columns into an existing sheet in another workbook that has 36 columns. The Header names of the destination sheet don't match the header names of the sheet I'm copying from, but the data is the compatible.




AlphaFrog posted this back in 2009:
[CODE}
Sub Copy_Columns()
Dim vHeader As Variant, rngFound As Range, i As Long
For Each vHeader In Array("District", "Address", "Contact Person")
Set rngFound = Sheets(1).Cells.Find(vHeader, , xlValues, xlWhole, 1, 1, 0)
i = i + 1
If Not rngFound Is Nothing Then
Range(rngFound, rngFound.End(xlDown)).Copy Destination:=Sheets(2).Cells(1, i)
End If
Next
Sheets(2).Select
Columns.AutoFit
End Sub
[/CODE]

This is very close to what I need...but the problem is, for example, that the destination workbook has the header "Location" while the workbook I'm copying from has the header "District"...but the data in the columns is the same.

I need to find the column in the destination workbook that has "Location" as header and the paste the data from the "District" Column in the workbook I'm copying from.

any help would be appreciated!
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,775
Office Version
  1. 2016
Platform
  1. Windows
I am assuming that you have headers in row 1 on both sheets. So, I just copy from 2nd row down based on original code.

You have to match the array sequence for header labels based on position. You can match any header even is not related as long as the sequence match between both headers
VBA Code:
Sub Copy_Columns()

Dim vHeader As Variant, rngFound1 As Range, rngFound2 As Range, i As Long, Pos As Long
Dim ArryHeader1() As String, ArryHeader2() As String, colDest As String
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

ArryHeader1 = Split("District,Address,Contact Person", ",")
ArryHeader2 = Split("Location,Address,Contact Person", ",")

Application.ScreenUpdating = False

For Each vHeader In ArryHeader1
    Set rngFound1 = ws1.Cells.Find(vHeader, , xlValues, xlWhole, 1, 1, 0)
    i = i + 1
    If Not rngFound1 Is Nothing Then
        Pos = Application.Match(vHeader, ArryHeader1, False) - 1
        Set rngFound2 = ws2.Cells.Find(ArryHeader2(Pos), , xlValues, xlWhole, 1, 1, 0)
        colDest = Split(rngFound2.Address, "$")(1)
        Range(rngFound1.Offset(1), rngFound1.End(xlDown)).Copy Destination:=ws2.Range(colDest & "2")
    End If
Next
ws2.Select

End Sub
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,775
Office Version
  1. 2016
Platform
  1. Windows
Sorry. I did not clean up the code. There are unnecessary line. Here is updated one
VBA Code:
Sub Copy_Columns()

Dim Pos As Long
Dim vHeader As Variant
Dim rngFound1 As Range, rngFound2 As Range
Dim ArryHeader1() As String, ArryHeader2() As String
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

ArryHeader1 = Split("District,Address,Contact Person", ",")
ArryHeader2 = Split("Location,Address,Contact Person", ",")

Application.ScreenUpdating = False

For Each vHeader In ArryHeader1
    Set rngFound1 = ws1.Cells.Find(vHeader, , xlValues, xlWhole, 1, 1, 0)
    If Not rngFound1 Is Nothing Then
        Pos = Application.Match(vHeader, ArryHeader1, False) - 1
        Set rngFound2 = ws2.Cells.Find(ArryHeader2(Pos), , xlValues, xlWhole, 1, 1, 0)
        Range(rngFound1.Offset(1), rngFound1.End(xlDown)).Copy Destination:=rngFound2.Offset(1)
    End If
Next
ws2.Select

End Sub
 

blbat

Active Member
Joined
Mar 24, 2010
Messages
323
Sorry. I did not clean up the code. There are unnecessary line. Here is updated one
VBA Code:
Sub Copy_Columns()

Dim Pos As Long
Dim vHeader As Variant
Dim rngFound1 As Range, rngFound2 As Range
Dim ArryHeader1() As String, ArryHeader2() As String
Dim ws1 As Worksheet, ws2 As Worksheet

Set ws1 = ActiveWorkbook.Sheets(1)
Set ws2 = ActiveWorkbook.Sheets(2)

ArryHeader1 = Split("District,Address,Contact Person", ",")
ArryHeader2 = Split("Location,Address,Contact Person", ",")

Application.ScreenUpdating = False

For Each vHeader In ArryHeader1
    Set rngFound1 = ws1.Cells.Find(vHeader, , xlValues, xlWhole, 1, 1, 0)
    If Not rngFound1 Is Nothing Then
        Pos = Application.Match(vHeader, ArryHeader1, False) - 1
        Set rngFound2 = ws2.Cells.Find(ArryHeader2(Pos), , xlValues, xlWhole, 1, 1, 0)
        Range(rngFound1.Offset(1), rngFound1.End(xlDown)).Copy Destination:=rngFound2.Offset(1)
    End If
Next
ws2.Select

End Sub
Thanks for this Zot...am I seeing by your use of two variables for the worksheets that you are assuming they are both in same workbook? That's probably a better idea, because I can just copy the whole sheet from one workbook to another, without VBA, first, then run the code.
If you're still interested...I will post results sometime next week. Thanks Again!
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,775
Office Version
  1. 2016
Platform
  1. Windows
Thanks for this Zot...am I seeing by your use of two variables for the worksheets that you are assuming they are both in same workbook? That's probably a better idea, because I can just copy the whole sheet from one workbook to another, without VBA, first, then run the code.
If you're still interested...I will post results sometime next week. Thanks Again!
I read title and focus on the sample code you pasted and missed the point you said copying from another workbook. My fault. I can modify the code to read from another workbook.
 

Zot

Well-known Member
Joined
Nov 26, 2020
Messages
1,775
Office Version
  1. 2016
Platform
  1. Windows
This code is in workbook where you want to copy data from. It will copy from this workbook to another workbook you select during run.

You just need to run the macro and it will ask for destination workbook. This code is tested okay

VBA Code:
Sub Copy_Columns()

Dim Pos As Long
Dim vHeader As Variant
Dim rngFoundA As Range, rngFoundB As Range
Dim ArryHeaderA() As String, ArryHeaderB() As String
Dim wsA As Worksheet, wsB As Worksheet
Dim wbA As Workbook, wbB As Workbook

Set wsA = ActiveWorkbook.Sheets("Sheet1") ' Change name accordingly if required

ArryHeaderA = Split("District,Address,Contact Person", ",")
ArryHeaderB = Split("Location,Address,Contact Person", ",")

Application.ScreenUpdating = False

' Search destination Workbook
Fname = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls; *.xlsx; *.xlsm; *.xlsb), *.xls; *.xlsx; *.xlsm; *.xlsb", Title:="Select a File")
If Fname = False Then Exit Sub                         'CANCEL is clicked

' Define opened Workbook as wbB while opening it.
Set wbB = Workbooks.Open(Filename:=Fname, UpdateLinks:=False, ReadOnly:=True, IgnoreReadOnlyRecommended:=True)
' Define working sheet in wbB. Change sheet name accordingly
Set wsB = wbB.Sheets("Sheet1") ' Change name accordingly if required

For Each vHeader In ArryHeaderA
    Set rngFoundA = wsA.Cells.Find(vHeader, , xlValues, xlWhole, 1, 1, 0)
    If Not rngFoundA Is Nothing Then
        Pos = Application.Match(vHeader, ArryHeaderA, False) - 1
        Set rngFoundB = wsB.Cells.Find(ArryHeaderB(Pos), , xlValues, xlWhole, 1, 1, 0)
        Range(rngFoundA.Offset(1), rngFoundA.End(xlDown)).Copy Destination:=rngFoundB.Offset(1)
    End If
Next
wsB.Select

End Sub
 

Forum statistics

Threads
1,144,524
Messages
5,724,842
Members
422,585
Latest member
k3n

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top