Excel VBAmacros – search列名，然后复制到同一工作簿Excel 2010中另一个模板工作表上的定义列中
我似乎无法得到这个工作，我不知道哪里有问题。
它编译好，但它没有在我的床单上。 我正在尝试编写一个macros将按列标题复制数据并粘贴到同一个工作簿中具有相同标题的另一个模板工作表。
例如 ，将数据复制到导入工作表的“Time Started”列下，复制新数据并粘贴到Main工作表的“Time Started”列中。
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 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