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

我似乎无法让这项工作正常进行，我看不出哪里有问题

它编译得很好，但在我的工作表上什么也做不了。我正在尝试编写一个宏，它将按列标题复制数据，并粘贴到同一工作簿中具有相同标题的另一个模板工作表中

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

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

---

我将您的循环改写为2

，对于

循环，请尝试一下： （在线评论）

---

我将您的循环改写为2

，对于

循环，请尝试一下： （在线评论）

---

请注意，可变尺寸似乎不正确。键入

Dim rngCopy作为范围时，rngCopyTo

仅将第一个

rngCopy

声明为范围，将第二个

rngCopyTo

声明为变量类型变量。这不会直接影响您的问题，但应该注意，因为这是一种不好的习惯，会导致您在编写代码时遇到麻烦。您是否尝试过单步执行代码？如果它没有复制任何数据，那么您的一些测试就没有达到预期效果。请注意，变量维度似乎不正确。键入

Dim rngCopy作为范围时，rngCopyTo

仅将第一个

rngCopy

声明为范围，将第二个

rngCopyTo

声明为变量类型变量。这不会直接影响您的问题，但应该注意，因为这是一种不好的习惯，会导致您在编写代码时遇到麻烦。您是否尝试过单步执行代码？如果它没有复制任何数据，那么您的一些测试就没有达到预期效果。这非常有效，唯一的问题是“Main”上的标题被覆盖。有没有办法指定信息粘贴的位置？模板是为第6行以下的任何内容设计的，因此需要粘贴到第7行。如果你能帮忙，谢谢你！在粘贴行中添加一个加号6，使其看起来像是

shtMain.Cells（lCopyRow+6，lCopyColumn）。Value=shtImport.Cells（lCopyRow，lCopyColumn）。Value

我不是100%了解电子表格标题的布局方式，但是如果需要偏移位置，我现在遇到的问题是，如果工作表上的“导入”选项卡的列顺序与模板中的列顺序不同，它只会导入到错误的列中。（例如，如果数据粘贴到主工作表中，但“时间开始列”已移动到另一列，它将在错误的列下粘贴“时间开始”）…是否有方法将数据与两个工作表之间的列标题相匹配？vlookup是最好的选择吗？现在，

lLastRowOfColumn

循环通过输入列，并将它们直接粘贴到同一位置的输出。如果您需要动态查找粘贴位置，我建议您在目标工作表的标题行中使用for循环，以查找哪个标题与要将行粘贴到的列相匹配。@RCoy1978需要查看您的新代码，以说明如何优化它以提高速度。也许发布一个新问题？这很有效，唯一的问题是我在“Main”上的标题被覆盖了。有没有办法指定信息粘贴的位置？模板是为第6行以下的任何内容设计的，因此需要粘贴到第7行。如果你能帮忙，谢谢你！在粘贴行中添加一个加号6，使其看起来像是

shtMain.Cells（lCopyRow+6，lCopyColumn）。Value=shtImport.Cells（lCopyRow，lCopyColumn）。Value

我不是100%了解电子表格标题的布局方式，但是如果需要偏移位置，我现在遇到的问题是，如果工作表上的“导入”选项卡的列顺序与模板中的列顺序不同，它只会导入到错误的列中。（例如，如果数据粘贴到主工作表中，但“时间开始列”已移动到另一列，它将在错误的列下粘贴“时间开始”）…是否有方法将数据与两个工作表之间的列标题相匹配？vlookup是最好的选择吗？现在，

lLastRowOfColumn

循环通过输入列，并将它们直接粘贴到同一位置的输出。如果您需要动态查找粘贴位置，我建议您在目标工作表的标题行中使用for循环，以查找哪个标题与要将行粘贴到的列相匹配。@RCoy1978需要查看您的新代码，以说明如何优化它以提高速度。也许可以发布一个新问题？

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