Question

这是我想要做的：我在“报告”标签中有一个数据。 A列包含ID1，B列ID2，其余为其他数据。我想有一个宏，它获取给定ID2的所有行数据，并创建一个以特定格式命名的工作簿（名称包含该ID2）。它可以保存在与宏相同的文件夹中，或者要求用户指定位置。

至于现在，我已经尝试重建一个类似的宏：它创建标签而不是工作簿，我在将过滤器从A列更改为B列时遇到问题。

Sub PagesByDescription()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String

Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
'Set a range variable to the correct item column
Set rRange = Range("A1", Range("A65536").End(xlUp))

    'Delete any sheet called "UniqueList"
    'Turn off run time errors & delete alert
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("UniqueList").Delete

    'Add a sheet called "UniqueList"
    Worksheets.Add().Name = "UniqueList"

       'Filter the Set range so only a unique list is created
        With Worksheets("UniqueList")
            rRange.AdvancedFilter xlFilterCopy, , _
             Worksheets("UniqueList").Range("a1"), True

             'Set a range variable to the unique list, less the heading.
             Set rRange = .Range("a1", .Range("A65536").End(xlUp))
        End With

        On Error Resume Next
        With wSheetStart
            For Each rCell In rRange
              strText = rCell
             .Range("A1").AutoFilter 1, strText
                Worksheets(strText).Delete
                'Add a sheet named as content of rCell
                Worksheets.Add().Name = strText
                'Copy the visible filtered range _
                (default of Copy Method) and leave hidden rows
                .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
                ActiveSheet.Cells.Columns.AutoFit
            Next rCell
        End With

    With wSheetStart
        .AutoFilterMode = False
        .Activate
    End With

    On Error GoTo 0
    Application.DisplayAlerts = True
End Sub

有人能给我一个提示吗？在代码中将A1更改为B1不起作用..

提前感谢大家！

=========================================

更新：我添加了一个循环，但它似乎没有正确完成。

Sub PagesByDescription()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String
dim i as integer

Set wSheetStart = ActiveSheet
wSheetStart.AutoFilterMode = False
'Set a range variable to the correct item column
Set rRange = Range("A1", Range("A65536").End(xlUp))

    'Delete any sheet called "UniqueList"
    'Turn off run time errors & delete alert
    'On Error Resume Next
    Application.DisplayAlerts = False
   ' Worksheets("UniqueList").Delete

    'Add a sheet called "UniqueList"
  '  Worksheets.Add().Name = "UniqueList"


    Worksheets.Add(After:=Worksheets(1)).Name = "UniqueList"

       'Filter the Set range so only a unique list is created
        With Sheets("UniqueList")
            rRange.AdvancedFilter xlFilterCopy, , _
             Worksheets("UniqueList").Range("a1"), True

             'Set a range variable to the unique list, less the heading.
             Set rRange = .Range("a1", .Range("A65536").End(xlUp))
        End With

        'On Error Resume Next
        With wSheetStart
            For Each rCell In rRange
              strText = rCell
              for i = 1 to 2
             .Range("1:1").AutoFilter i, strText
              next i
                'Worksheets(strText).Delete
                'Add a sheet named as content of rCell
                'Worksheets.Add().Name = strText
                Worksheets.Add(After:=Worksheets(1)).Name = strText
                'Copy the visible filtered range _
                (default of Copy Method) and leave hidden rows
                .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
                ActiveSheet.Cells.Columns.AutoFit
            Next rCell
        End With

    With wSheetStart
        .AutoFilterMode = False
        .Activate
    End With

    On Error GoTo 0
    Application.DisplayAlerts = True
End Sub

它仍然使用列A进行过滤，现在甚至不复制任何内容，只创建由唯一列表命名的选项卡。

Answer 1

请使用过滤器上的下一个循环从1移动到2.如果要同时使用两个过滤器，也可以使用新过滤器添加第二行。

Answer 2

请参考打击示例： -

Sub etst（）

Dim i As Integer

对于i = 1到2

Range("1:1").AutoFilter i, ">" & 1200

接下来我

End Sub

创建基于工作表中的数据命名的工作簿

2 个答案: