Copy data from one worksheet to another based on c

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

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

Answer 2

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