Question

I can’t seem to get this to work, I don’t see where there is an issue.

It compiles fine, but it does nothing on my sheets. I am trying to write a macro that will Copy data by column header and paste into another template sheet within the same workbook with the same header.

For example, copy data under column “Time Started” on the import sheet, copy the new data, and paste into “Time Started” column on the Main sheet.

Sub CopyByHeader()

Dim shtImport As Worksheet, shtMain As Worksheet
Dim c As Range, f As Range
Dim rngCopy As Range, rngCopyTo

Set shtImport = ActiveSheet ' "import" - could be different workbook
Set shtMain = ThisWorkbook.Sheets("Main")

For Each c In Application.Intersect(shtImport.UsedRange, shtImport.Rows(1))
    'only copy if >1 value in this column (ie. not just the header)
    If Len(c.Value) > 0 And Application.CountA(c.EntireColumn) > 1 Then
        Set f = shtMain.Rows(1).Find(what:=c.Value, LookIn:=xlValues, _
        LookAt:=xlWhole)
        If Not f Is Nothing Then
            Set rngCopy = shtImport.Range(c.Offset(1, 0), _
                shtImport.Cells(Rows.Count, c.Column).End(xlUp))
            Set rngCopyTo = shtMain.Cells(Rows.Count, _
                f.Column).End(xlUp).Offset(1, 0)
            'copy values
            rngCopyTo.Resize(rngCopy.Rows.Count, 1).Value = rngCopy.Value
        End If
    End If
 Next c

 End Sub

---

I changed to this, which is super slow…any thoughts??:

Sub ImportTimeStudy()
Dim myHeaders, e, x, wsImport As Worksheet, wsMain As Worksheet
Dim r As Range, c As Range

myHeaders = Array(Array("Time Started", "Time Started"), Array("Description of the task", "Description of the task"), Array("Level", "Level"), Array("Location", "Location"), Array("Targeted", "Targeted"), Array("System", "System"), Array("Process Code", "Process Code"), _
            Array("Value Stream", "Value Stream"), Array("Subject", "Subject"), Array("BU", "BU"), Array("Task Duration", "Task Duration"), Array("Activity Code", "Activity Code"))

Set wsImport = Sheets("Import")
Set wsMain = Sheets("Main")

For Each e In myHeaders

    Set r = wsImport.Cells.Find(e(0), , , xlWhole)

    If Not r Is Nothing Then
        Set c = wsMain.Cells.Find(e(1), , , xlWhole)

        If Not c Is Nothing Then
            wsImport.Range(r.Offset(1), wsImport.Cells(Rows.Count, r.Column).End(xlUp)).Copy _
            wsMain.Cells(Rows.Count, c.Column).End(xlUp)(2)
        Else
            msg = msg & vbLf & e(1) & " " & wsMain.Name
        End If
    Else
        msg = msg & vbLf & e(0) & " " & wsImport.Name
    End If

Next

If Len(msg) Then
    MsgBox "Header not found" & msg

End If

Application.ScreenUpdating = False

End Sub

Answer 1

I rewrote your loops to be 2 for loops, give this a try:
(comments in-line)

Sub CopyByHeader()


Dim shtImport As Worksheet
Dim shtMain As Worksheet
Set shtImport = ActiveSheet ' "import" - could be different workbook
Set shtMain = ThisWorkbook.Sheets("Main")

Dim lCopyColumn As Long
Dim lCopyRow As Long
Dim lLastRowOfColumn As Long

'- for each column in row 1 of import sheet
For lCopyColumn = 1 To shtImport.Cells(1, shtImport.Columns.Count).End(xlToLeft).Column
    '- check what the last row is with data in column
    lLastRowOfColumn = shtImport.Cells(shtImport.Rows.Count, lCopyColumn).End(xlUp).Row

    'if last row was larger than one then we will loop through rows and copy
    If lLastRowOfColumn > 1 Then
        For lCopyRow = 1 To lLastRowOfColumn
            '- note we are copying to the corresponding cell address, this can be modified.
            shtMain.Cells(lCopyRow, lCopyColumn).Value = shtImport.Cells(lCopyRow, lCopyColumn).Value
        Next lCopyRow
    End If
Next lCopyColumn

End Sub