Excel VBA宏-搜索列名，然后复制到同一工作簿Excel 2010中另一个模板工作表上的已定义列

Question

我似乎无法解决这个问题，看不到问题所在。

它可以很好地编译，但是对我的工作表没有任何作用。 我正在尝试编写一个宏，该宏将按列标题复制数据并粘贴到同一工作簿中具有相同标题的另一个模板工作表中。

例如 ，将数据复制到导入表的“开始时间”列下，复制新数据，然后粘贴到主表的“开始时间”列中。

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

---

我改成了这个，这太慢了...任何想法??：

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

我将您的循环改写为2 for loops，尝试一下：（在线注释）

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