过滤每个值，将每个表复制并粘贴到新工作表中

Question

我想使用vba代码以便顺序选择表中的每个值并将它们复制到新表中。如图所示，有一个表，在F列中，我们有2个不同的值（可能大于2）。我需要的是，当我运行宏时，它将选择第一个值，然后将表复制到新工作表中（工作表的名称将基于F列中的值，例如0.55），然后返回并选择第二个值并做同样的事情。我们可能有6-7个以上的值，因此我不知道如何对所有值自动执行循环。我需要在该代码块的末尾添加此过程。因为该代码做了一些不同的事情，结果我得到了那个表。

Private Sub CommandButton2_Click()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim x As Workbook
Dim y As Workbook
Dim q As Workbook




'## Open all workbooks first:
Set x = Workbooks.Open("C:\Users\mammadov.ali\Desktop\macros\barkod.xlsx")
Set y = Workbooks.Open("C:\Users\mammadov.ali\Desktop\macros\csv.csv")
Set q = Workbooks.Open("C:\Users\mammadov.ali\Desktop\macros\campaign.xlsx")


'## Clear the workbook first:
Windows("csv.csv").Activate
y.Sheets("csv").Range("A:M").Clear


'## Insert the column in the barkod file:
Windows("barkod.xlsx").Activate
x.Sheets("barkod").Range("F1").EntireColumn.Insert

'## Insert the column header in the barkod file:
x.Sheets("barkod").Range("E1").Offset(0, 1).Value = "Discounts"

'## make the vlookup in barkod file:
With x.Sheets("barkod").Range("F2")
    .FormulaR1C1 = "=VLOOKUP(RC[-1], [campaign.xlsx]Sheet1!C[-5]:C[-4], 2, 0)"
    .AutoFill Destination:=.Resize(WorksheetFunction.CountA(.Offset(, -1).EntireColumn))
End With


'## deselect the #N/A:
Windows("barkod.xlsx").Activate
x.Sheets("barkod").Range(Sheets("barkod").Range("A1:F1"), Sheets("barkod").Range("A1:F1").End(xlDown)).Select
Selection.AutoFilter
ActiveSheet.Range("A:F").AutoFilter field:=6, Criteria1:="<>#N/A"


'Now, copy what you want from x:
x.Sheets("barkod").Range(Sheets("barkod").Range("A1:F1"), Sheets("barkod").Range("A1:F1").End(xlDown)).Copy


'Now, paste to y worksheet:
y.Sheets("csv").Range("A1").PasteSpecial

Answer 1

此过程应执行您想要的操作，以便您可以给它起一个有意义的名称，并在现有代码的末尾调用它。它使用高级过滤器在F中创建一个唯一项列表，然后使用“自动筛选”遍历每个项以创建新工作表。

Sub Macro2()

Dim r As Range, r2 As Range, ws As Worksheet

Application.DisplayAlerts = False

With Sheets("Sheet1")   'change to suit
    Sheets.Add().Name = "Temp"
    .Range("F1", .Range("F" & Rows.Count).End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("Temp").Range("A1"), Unique:=True
    Set r2 = Sheets("Temp").Range("A2", Sheets("Temp").Range("A2").End(xlDown))
     For Each r In r2
        .Range("A1").CurrentRegion.AutoFilter field:=6, Criteria1:=r
        Set ws = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        .AutoFilter.Range.Copy ws.Range("A1")
        ws.Name = r
        .Range("A1").CurrentRegion.AutoFilter field:=6
    Next r
    Sheets("Temp").Delete
    .AutoFilterMode = False
End With

Application.DisplayAlerts = True

End Sub