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）”之前或之后沒有空格
• 主選項卡名稱恰好是“離岸搜索”，它只包含一個按鈕（“創建選項卡”）