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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.