Copy data from one worksheet to another based on column - vba

Question

I am trying to write a macro that will copy data from one worksheet to another based on column headers. Lets say in ws1 there are three columns: "product", "name", "employer" and the ws2: "product", "name", "region".
So i want the macro to do all the copying as in my original file i have over 100 column headers and it will be very time consuming for to do it myself.
I have written two macros without succes. VBA is something I cant understand for quite some time. but still managed to write something, hope you can tell me if i am going in the right direction.
this is v1
Sub Copy_rangev1()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim SourceRange As Range, CopyRange As Range
Dim lastrow As Long
Dim i As Integer
Set Ws1 = ThisWorkbook.Worksheets("Sheet1")
Set Ws2 = ThisWorkbook.Worksheets("sheet2")
lastrow = Cells(Rows.Count, 1).End(xlUp).Row + 1
Set SourceRange = Ws2.Range("A1").CurrentRegion
Set CopyRange = Ws1.Range("A1").CurrentRegion
For i = 1 To lastrow
If SourceRange.Cells(i, 1).Value = CopyRange.Cells(i, 1) Then
SourceRange.Cells(i + 1 & lastrow, 1).Copy Destination:=CopyRange.Range("a" & lastrow)
End If
Next i
End Sub
this v2:
Sub Copyrangev2()
Dim SourceRange As Worksheet
Dim CopyRange As Worksheet
Dim lastrow As Integer
Set SourceRange = Worksheets("Sheet2")
Set CopyRange = ThisWorkbook.Worksheets("sheet1")
Dim i As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To 100
If SourceRange.Range(1, i).Value = CopyRange.Range(1, i) Then
SourceRange.Range(1, i).Offset(1, 0).Copy Destination:=CopyRange.Range(1, i)
End If
Next i
End Sub
My code is a mess, but if you want me to provide any more details leave a comment, i dont expect you to given a fully workable code, a good explanation and few suggestions will do. Thanks

Answer 1

How about this? This code works as follows
Iterate across each column header in ws1 and see if a matching
header exists in ws2
If a match is found, copy the column contents across to the relevant column in ws2
This will work irrespective of column order. You can change the range references to suit.
Sub CopyHeaders()
Dim header As Range, headers As Range
Set headers = Worksheets("ws1").Range("A1:Z1")
For Each header In headers
If GetHeaderColumn(header.Value) > 0 Then
Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("ws2").Cells(2, GetHeaderColumn(header.Value))
End If
Next
End Sub
Function GetHeaderColumn(header As String) As Integer
Dim headers As Range
Set headers = Worksheets("ws2").Range("A1:Z1")
GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

Answer 2

Sub CustomColumnCopy()
Dim wsOrigin As Worksheet
Dim wsDest As Worksheet
Dim rngFnd As Range
Dim rngDestSearch As Range
Dim CalcMode As Long
Dim ViewMode As Long
Dim cel As Range
Dim rownum As Range
Set wsOrigin = Sheets("Sheet1")
Set wsDest = Sheets("Sheet2")
Const ORIGIN_ROW_HEADERS = 1
Const DEST_ROW_HEADERS = 1
If ActiveWorkbook.ProtectStructure = True Or _
wsOrigin.UsedRange.Parent.ProtectContents = True Then
MsgBox "Sorry, not working when the workbook or worksheet is protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False
For Each rownum In wsOrigin.UsedRange
Set rngDestSearch = Intersect(wsDest.UsedRange, wsDest.Rows(DEST_ROW_HEADERS))
For Each cel In Intersect(wsOrigin.UsedRange, wsOrigin.Rows(ORIGIN_ROW_HEADERS))
On Error Resume Next
Set rngFnd = rngDestSearch.Find(cel.Value)
If Not rngFnd Is Nothing Then
wsDest.Cells(rownum.Cells.row, rngFnd.Column).Value = wsOrigin.Cells(rownum.Cells.row, cel.Column).Value
End If
On Error GoTo 0
Set rngFnd = Nothing
Next cel
Next rownum
ActiveWindow.View = ViewMode
Application.GoTo wsDest.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
Dim keyRange As Range
Set keyRange = Range("A1")
wsDest.Range("A" & LastRow(wsDest) + 1).Sort Key1:=keyRange, Header:=xlYes
End Sub