Question

我对VBA很新，经过5个小时的观看视频和Google搜索后，我觉得这太过分了......非常感谢任何帮助。

所以我有2个excel工作表：Sheet1和Sheet2。我在Sheet1中有一个Y / N列，如果列=＆＃34; Y＆＃34;然后我想复制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为null（循环）。结果将是：

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中的列，它也会起作用。

Sub CopySheet（） Dim i As Integer Dim LastRow作为整数 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

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

它的工作方式非常灵活，而且非常可扩展。不依赖于具有相同列等的两张纸......我可以看到这在将来非常有用。：）

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

3 个答案: