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 循环，试试这个： (cmets 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