基于列名使用VBA将数据从一个excel工作表复制到另一个（复杂）工作表

我对VBA很陌生，在看了5个小时的视频和谷歌搜索之后，我觉得这太让我不知所措了。。。非常感谢您的帮助

所以我有两张excel工作表：Sheet1和Sheet2。我在Sheet1中有一个Y/N列，如果该列为“Y”，则我希望复制Sheet2中具有匹配列名的行中的所有数据

Sheet1
Product     Price     SalesPerson    Date    Commission     Y/N
  A          $25         John       1/9/15      $3           Y 
  B          $20         John       1/12/15     $2           N  
  B          $15         Brad       1/5/15      $1           Y

Sheet2
Price     Product     Date     Salesperson   

因此，每次Y/N=Y时，将匹配的数据复制到sheet2，直到sheet1.col1为空（循环）。结果是：

Sheet2
Price     Product     Date     Salesperson
 $25         A       1/9/15        John
 $15         B       1/5/15        Brad

这些列不符合顺序，而且数量太多，无法手动输入。最后但并非最不重要的一点是，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

---

这是为了做一些不同于我正在尝试做的事情，我不认为我有能力改变它来为我工作。我是如何做到这一点的？

好的，如果Sheet2中的列在Sheet1中不存在，那么它也可以工作

子副本（） 作为整数的Dim i 将最后一行设置为整数 以字符串形式搜索 将列设置为整数

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

Sheets（“Sheet1”）。激活
图纸（“图纸1”）。范围（“A1”）。选择
'设置一个自动筛选，仅对“是”行进行排序。
选择。自动筛选
'将字段：=5更改为具有Y/N的列的编号。
表（“表1”）。范围（$A$1:$G$3”）。自动筛选字段：=7，标准1:=Y
'查找最后一行
LastRow=工作表（“Sheet1”）。单元格（工作表（“Sheet1”）。行。计数，“A”）。结束（xlUp）。行
i=1
'将3更改为Sheet2中的列数
在i时执行此操作。如果列与上面提到的列相同（表1中的A到F和表2中的A到D），您也可以尝试此操作

在进一步研究这个问题时，我正在考虑为标题创建一个静态数组。。。然后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

这是一种非常灵活的工作方式，并且具有很强的可扩展性。这并不依赖于两张表都有相同的列等。我可以看到这在将来非常有用。
因此，我的sheet2确实有sheet1中没有的列：（即使sheet2中的列在sheet1中不存在，也将其更改为有效。我将做更多的研究，并将更新此内容，但我无法使此代码正常工作…可能是因为sheet2中包含的列不在sheet1中。）
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