Excel VBA 宏 - 搜索列名称，然后复制到同一工作簿 Excel 2010 中另一个模板工作表上的定义列中
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/12481824/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel VBA Macro--Search For Column names and then copy into defined columns on another template worksheet in same workbook Excel 2010
提问by RCoy1978
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
回答by danielpiestrak
I rewrote your loops to be 2 forloops, give this a try:
(comments in-line)
我将你的循环重写为 2 个for循环，试试这个：（在线评论）
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
