使用VBA根據列名將數據從一個Excel工作表復制到另一個（復雜）工作表

Question

我是VBA的新手，經過5個小時的觀看視頻和谷歌搜索，我認為這太過頭了……非常感謝您的幫助。

所以我有2個excel工作表：Sheet1和Sheet2。 我在Sheet1中有一個Y / N列，如果column =“ 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

此功能旨在執行與我嘗試執行的操作不同的操作，並且我認為我無法更改此設置以適合我的工作。 我要怎么做？

Answer 1

好了，如果Sheet2中有Sheet1中不存在的列，那么現在也可以使用。

子CopySheet（）昏暗i作為整數昏暗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$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

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

在進行進一步研究時，我正在考慮為標頭創建一個靜態數組...然后，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

它的工作方式十分流暢，並且具有很好的可擴展性。 不依賴於兩張紙具有相同的列等。我可以看到這在將來很有用。 :)