使用基于列名称的VBA将数据从一个Excel表复制到另一个（复杂）
我对VBA很陌生，经过5个小时的观看video和谷歌search，我认为这是太过于我的头…任何帮助，非常感激。
所以我有2个Excel工作表：Sheet1和Sheet2。 我在Sheet1中有一个Y / N列，如果列=“Y”，那么我想复制该行中与Sheet2中具有匹配列名称的所有数据。
Sheet1 Product Price SalesPerson Date Commission Y/N A $25 John 1/9/15 $3 YB $20 John 1/12/15 $2 NB $15 Brad 1/5/15 $1 Y Sheet2 Price Product Date Salesperson 因此，对于每次Y / N = Y，然后将匹配的数据复制到sheet2，直到sheet1.col1为null（循环）。 结果是这样的：
Sheet2 Price Product Date Salesperson $25 A 1/9/15 John $15 B 1/5/15 Brad
这些列不合适，数量太多，无法手动input。 然后最后但并非最不重要的Y / N列将需要完成后清除。 我试图改变这个没有运气：
Sub CopyHeaders() Dim header As Range, headers As Range Set headers = Worksheets("Sheet1").Range("A1:Z1") For Each header In headers If GetHeaderColumn(header.Value) > 0 Then Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=Worksheets("Sheet2").Cells(2, GetHeaderColumn(header.Value)).End(xlDown).Offset(1, 0) End If Next End Sub Function GetHeaderColumn(header As String) As Integer Dim headers As Range Set headers = Worksheets("Sheet2").Range("A1:Z1") GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0) End Function
这是为了做一些不同于我想要做的事情，我不认为我能够改变这个为我工作。 我该怎么做呢？
好吧，现在如果在Sheet1中有Sheet1中不存在的列，它也可以工作。
Sub CopySheet（）Dim i As Integer Dim LastRow As Integer Dim Search As String Dim Column As Integer
Sheets("Sheet1").Activate Sheets("Sheet1").Range("A1").Select 'Sets an Autofilter to sort out only your Yes rows. Selection.Autofilter 'Change Field:=5 to the number of the column with your Y/N. Sheets("Sheet1").Range("$A$1:$G$3").Autofilter Field:=7, Criteria1:="Y" 'Finds the last row LastRow = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row i = 1 'Change the 3 to the number of columns you got in Sheet2 Do While i <= 3 Search = Sheets("Sheet2").Cells(1, i).Value Sheets("Sheet1").Activate 'Update the Range to cover all your Columns in Sheet1. If IsError(Application.Match(Search, Sheets("sheet1").Range("A1:G1"), 0)) Then 'nothing Else Column = Application.Match(Search, Sheets("sheet1").Range("A1:G1"), 0) Sheets("Sheet1").Cells(2, Column).Resize(LastRow, 1).Select Selection.Copy Sheets("Sheet2").Activate Sheets("Sheet2").Cells(2, i).Select ActiveSheet.Paste End If i = i + 1 Loop 'Clear all Y/N = Y 'Update the Range to cover all your Columns in Sheet1. Sheets("Sheet1").Activate Column = Application.Match("Y/N", Sheets("sheet1").Range("A1:G1"), 0) Sheets("Sheet1").Cells(2, Column).Resize(LastRow, 1).Select Selection.ClearContents End Sub
您也可以尝试这一点，只要列如上所述（sheet1中的A到F和sheet2中的A到D）。
Sub copies() Dim i, j, row As Integer j = Worksheets("sheet1").Range("A1").End(xlDown).row For i = 1 To j If Cells(i, 6) = "Y" Then _ row = Worksheets("sheet2").Range("A1").End(xlDown).row + 1 Worksheets("sheet2").Cells(row, 1) = Worksheets("sheet1").Cells(i, 2) Worksheets("sheet2").Cells(row, 2) = Worksheets("sheet1").Cells(i, 1) Worksheets("sheet2").Cells(row, 3) = Worksheets("sheet1").Cells(i, 4) Worksheets("sheet2").Cells(row, 4) = Worksheets("sheet1").Cells(i, 3) Next Worksheets("sheet1").Range("F:F").ClearContents End Sub
当进一步研究这个时，我正在研究为头创build一个静态数组…然后user3561813提供了这个gem（我为if语句稍微修改了它，并循环遍历表：
Sub validatetickets() Do Until ActiveCell.Value = "" If Cells(ActiveCell.Row, 43) = "Y" Then Dim wsOrigin As Worksheet Dim wsDest As Worksheet Dim nCopyRow As Long Dim nPasteRow As Long Dim rngFnd As Range Dim rngDestSearch As Range Dim cel As Range Const ORIGIN_ROW_HEADERS = 1 Const DEST_ROW_HEADERS = 1 Set wsOrigin = Sheets("Case") Set wsDest = Sheets("Sheet1") nCopyRow = ActiveCell.Row nPasteRow = wsDest.Cells(Rows.Count, 1).End(xlUp).Row + 1 Set rngDestSearch = Intersect(wsDest.UsedRange, wsDest.Rows(DEST_ROW_HEADERS)) For Each cel In Intersect(wsOrigin.UsedRange, wsOrigin.Rows(ORIGIN_ROW_HEADERS)) On Error Resume Next Set rngFnd = rngDestSearch.Find(cel.Value) If rngFnd Is Nothing Then 'Do Nothing as Header Does not Exist Else wsDest.Cells(nPasteRow, rngFnd.Column).Value = wsOrigin.Cells(nCopyRow, cel.Column).Value End If On Error GoTo 0 Set rngFnd = Nothing Next cel ActiveCell.Offset(1, 0).Select Else: ActiveCell.Offset(1, 0).Select End If Loop End Sub
这是非常光滑的，它的工作方式是非常可扩展的。 不依赖于两个具有相同的列等表…我可以看到这是非常有用的未来。 🙂