根据列名使用 VBA 将数据从一个 excel sheet 复制到另一个（复杂）

Question

我是 VBA 的新手，在观看视频和谷歌搜索 5 小时后，我觉得这太过头了...非常感谢任何帮助。

所以我有 2 个 excel 工作表：Sheet1 和 Sheet2。我在 Sheet1 中有一个 Y/N 列，如果列 = "Y" 那么我想从 Sheet2 中具有匹配列名的那一行复制所有数据。

Sheet1
Product     Price     SalesPerson    Date    Commission     Y/N
  A                   John       1/9/15                 Y 
  B                   John       1/12/15                N  
  B                   Brad       1/5/15                 Y

Sheet2
Price     Product     Date     Salesperson

所以每次 Y/N = Y 然后将匹配的数据复制到 sheet2 并执行此操作直到 sheet1.col1 为空（循环）。结果将是这样的：

Sheet2
Price     Product     Date     Salesperson
          A       1/9/15        John
          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

这是为了做一些与我想做的不同的事情而设计的，我认为我无法改变它来为我工作。我该怎么做？

Answer 1

好的，现在如果您在 Sheet2 中有在 Sheet1 中不存在的列，它也可以工作。

子副本表() 将我调暗为整数将 LastRow 调暗为整数暗淡搜索作为字符串将列暗淡为整数

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:$G").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

Answer 2

你也可以试试这个，只要列是你上面提到的（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

Answer 3

在进一步研究时，我正在考虑为 headers 创建一个静态数组...然后 user3561813 提供了这个 gem（我为我的 if 语句稍微修改了它并循环遍历sheet:

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

它的工作方式非常巧妙，而且可扩展性很强。不依赖于两个 sheet 具有相同的列等......我可以看到这在未来非常有用。 :)

根据列名使用 VBA 将数据从一个 excel sheet 复制到另一个（复杂）

Copy data from one excel sheet to another (complex) using VBA based on column name

excel

vba

header