VBA Advanced AutoFilter +根据范围创建新工作表

Question

我需要根据工作表模板中的一系列单元格在工作簿中创建新选项卡。 我还想删除与选项卡名称不匹配的数据行。 例如，从下表中我将有一个名为“2206 - 6”的新选项卡，并且只保留与之关联的数据，请记住，每次使用宏时，此范围的数据都会更改。

之前 ：

之后 ：

---

区间号码2206 - 6 6304 - 5 4102 - 20

该表从第11行开始，但我需要保留上面的所有信息。 我有一个高级过滤宏，它接近我想要的，但它做了两件我不想要的事情：创建空标签而不保留第11行上方的信息。

Sub parse_data()
    Dim lr As Long
    Dim ws As Worksheet
    Dim vcol, i As Integer
    Dim icol As Long
    Dim myarr As Variant
    Dim title As String
    Dim titlerow As Integer

    vcol = 1
    Set ws = Sheets("Offshore Searches")
    lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
    title = "A11:G20"
    titlerow = ws.Range(title).Cells(1).Row
    icol = ws.Columns.Count
    ws.Cells(1, icol) = "Unique"

    For i = 2 To lr
        On Error Resume Next
        If ws.Cells(i, vcol) <> "" And _
          Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
            ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
        End If
    Next

    myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
    ws.Columns(icol).Clear

    For i = 2 To UBound(myarr)
        ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
        If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
            Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
        Else
            Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
        End If
        ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
        Sheets(myarr(i) & "").Columns.AutoFit
    Next
    ws.AutoFilterMode = False
    ws.Activate
End Sub

我还有一个宏，它根据没有高级过滤器的范围创建标签，因此每个标签看起来都相同（只是标签名称更改）

Sub CreateWorkSheetByRange()
    Dim WorkRng As Range
    Dim ws As Worksheet
    Dim arr As Variant

    On Error Resume Next

    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
    arr = WorkRng.Value
    Sheets("Offshore Searches").Select
        Cells.Select
        Selection.Copy
    Application.ScreenUpdating = False

    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            Set ws = Worksheets.Add(after:=Application.ActiveSheet)
            ws.Name = arr(i, j)
            ActiveSheet.Paste
            Range("A1").Select
        Next
    Next
    Application.ScreenUpdating = True
End Sub

有没有办法在同时使用高级过滤器的同时创建基于范围的标签？

Answer 1

对于你在图像中显示的内容，你可以尝试这样的东西来达到这个目的......

Sub InsertSheets()
Dim sws As Worksheet, ws As Worksheet
Dim slr As Long, i As Long
Dim Rng As Range, Cell As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set sws = Sheets("Sheet1")
If sws.Range("A12").Value = "" Then
    MsgBox "No Interval Numbers found on the sheet.", vbExclamation
    Exit Sub
End If
slr = sws.Range("A11").End(xlDown).Row
Set Rng = sws.Range("A12:A" & slr)
For Each Cell In Rng
    On Error Resume Next
    Sheets(Cell.Value).Delete
    On Error GoTo 0
    sws.Copy after:=Sheets(Sheets.Count)
    Set ws = ActiveSheet
    ws.Name = Cell.Value
    ws.DrawingObjects.Delete
    With ws
        For i = slr To 12 Step -1
            If i <> Cell.Row Then ws.Rows(i).Delete
        Next i
    End With
    Set ws = Nothing
Next Cell
sws.Activate
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Answer 2

另一个选择（测试）

所有功能都在一个单独的模块中
它复制主工作表，删除按钮并使用自动筛选器删除不需要的行

---

这使用字典和后期绑定很慢 ： CreateObject（“Scripting.Dictionary”）

早期绑定很快 ：VBA编辑器 - > 工具 - > 引用 - >添加Microsoft Scripting Runtime

---

Option Explicit

Private Const X As String = vbNullString
Public Sub CreateTabs()
    Const FIRST_CELL    As String = "Interval Number"
    Const LAST_CELL     As String = "Vesting Doc Number (LC/RS)"
    Dim wb As Workbook, ws As Worksheet, wsNew As Worksheet, d As Dictionary, i As Long
    Dim fr As Long, lr As Long, fc As Long, found As Range, rng As Range, val As String

    SetDisplay False
    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Offshore Searches")
    Set found = FindCell(ws.UsedRange, FIRST_CELL)
    If Not found Is Nothing Then
        fr = found.Row + 1
        fc = found.Column
    End If
    Set found = FindCell(ws.UsedRange, LAST_CELL)
    If Not found Is Nothing Then lr = found.Row - 1

    If fr > 0 And fc > 0 And lr >= fr Then
        If Not ws.AutoFilter Is Nothing Then ws.UsedRange.AutoFilter
        Set rng = ws.Range(ws.Cells(fr, fc), ws.Cells(lr, fc))
        Dim arr As Variant, r As Long
        arr = rng
        Set d = New Dictionary
        For r = 1 To UBound(arr)
            val = Trim(CStr(arr(r, 1)))
            val = CleanWsName(val)
            If Not d.Exists(val) Then d.Add r, val
        Next
        For i = 1 To d.Count
          If Not WsExists(d(i)) Then
            ws.Copy After:=wb.Worksheets(wb.Worksheets.Count)
            Set wsNew = wb.Worksheets(wb.Worksheets.Count)
            With wsNew
             .Name = d(i): If .Shapes.Count = 1 Then wsNew.Shapes.Item(1).Delete
             Set rng = .Range(.Cells(fr - 1, fc), .Cells(lr, fc))
         rng.AutoFilter Field:=1, Criteria1:="<>" & d(i), Operator:=xlAnd, Criteria2:="<>"
             Set rng = rng.Offset(1).Resize(rng.Rows.Count - 1)
             rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete Shift:=xlUp
             rng.AutoFilter
            End With
          End If
        Next
    End If
    ws.Activate
    SetDisplay True
End Sub

---

Public Sub SetDisplay(Optional ByVal status As Boolean = False)
    Application.ScreenUpdating = status
    Application.DisplayAlerts = status
End Sub

Public Function FindCell(ByRef rng As Range, ByVal celVal As String) As Range
    Dim found As Range
    If Not rng Is Nothing Then
        If Len(celVal) > 0 Then
            Set found = rng.Find(celVal, MatchCase:=True)
            If Not found Is Nothing Then Set FindCell = found
        End If
    End If
End Function

Public Function CleanWsName(ByVal wsName As String) As String
    Const x = vbNullString
    wsName = Trim$(wsName)    'Trim, then remove [ ] / \ < > : * ? | "
    wsName = Replace(Replace(Replace(wsName, "[", x), "]", x), " ", x)
    wsName = Replace(Replace(Replace(wsName, "/", x), "\", x), ":", x)
    wsName = Replace(Replace(Replace(wsName, "<", x), ">", x), "*", x)
    wsName = Replace(Replace(Replace(wsName, "?", x), "|", x), Chr(34), x)
    If Len(wsName) = 0 Then wsName = "DT " & Format(Now, "yyyy-mm-dd hh.mm.ss")
    CleanWsName = Left$(wsName, 31)         'Resize to max len of 31
End Function

Public Function WsExists(ByVal wsName As String) As Boolean
    Dim ws As Worksheet
    With ThisWorkbook
        For Each ws In .Worksheets
            If ws.Name = wsName Then
                WsExists = True
                Exit Function
            End If
        Next
    End With
End Function

---

假设

• 区间数字格式是一致的：单位＆“ - ”和周（= B12＆“ - ”和C12）
• 区间数不超过31个字符，并且不包含这些特殊字符：[] / \\？ *。
  • 如果是这样，工作表名称将缩短为31个字符
  • 并删除了所有提到的特殊字符（工作表名称的Excel限制）
• 工作行在单元格“间隔编号”之后开始，并在“归属文档编号（LC / RS）”之前停止
• “Interval Number”和“Vesting Doc Number（LC / RS）”之前或之后没有空格
• 主选项卡名称恰好是“离岸搜索”，它只包含一个按钮（“创建选项卡”）