使用基于列名的VBA将数据从一个excel表复制到另一个(复杂的)。

I'm very new to VBA and after 5 hours of watching videos and Googling, I think this is just too over my head... any help is very much appreciated.

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

So I have 2 excel worksheets: Sheet1 and Sheet2. I have a Y/N column in Sheet1 and if the column = "Y" then I want to copy all the data from that row that has a matching column name in Sheet2.

我有两个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

So for every time Y/N = Y then copy the data that matches over to sheet2 and do this until sheet1.col1 is null (looping). The result would be this:

因此，每次Y/N = Y，将匹配的数据复制到sheet2，直到sheet1。col1为空(循环)。其结果是:

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

The columns are not in order and are far too numerous to manually input. Then last but not least the Y/N column would need to clear upon finish. I have tried to alter this with no luck:

这些列不是有序的，而且数量太多，无法手动输入。最后但同样重要的是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

This was designed to do something different than what I'm trying to do and I don't think I'm capable of changing this to work for me. How wold I do this?

这是为了做一些与我想做的事情不同的事情，我认为我没有能力改变这一切来为我工作。我是怎么做到的?

3 个解决方案

#1

Alright, now it works also if you have columns in Sheet2 that do not exist in Sheet1.

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

Sub CopySheet() Dim i As Integer Dim LastRow As Integer Dim Search As String Dim Column As Integer

子CopySheet() Dim i为整数Dim LastRow，整数Dim搜索作为字符串Dim列为整数。

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

#2

You can try this also, provided that the columns are as you mentioned above (A to F in sheet1 and A to D in sheet2).

您也可以尝试一下，只要列如上所述(在sheet1中为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

#3

When researching this further I was looking into creating a static array for the headers... then user3561813 provided this gem (I altered it slightly for my if statement and to loop through the sheet:

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

This is pretty slick the way it works and is very scalable. Doesn't depend on both sheets having identical columns etc... I can see this being very useful in the future. :)

这是非常灵活的工作方式，而且是非常可伸缩的。不依赖于具有相同列的两张纸……我认为这在未来非常有用。:)

#1