VBAAdvancedAutoFilter+根据范围创建新工作表-VBAAdvancedAutoFilter+Createnewsheetsbasedonrange

1  

Another option (tested)

另一个选择(测试)

All functions bellow, in a separate module
It copies the main sheet, deletes the button and uses auto filter to remove unneeded rows

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

This uses dictionaries and late binding is slow: CreateObject("Scripting.Dictionary")

这使用字典和后期绑定很慢:CreateObject(“Scripting.Dictionary”)

Early binding is fast: VBA Editor -> Tools -> References -> Add Microsoft Scripting Runtime

早期绑定很快: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

Assumptions

• Interval Numbers format is consistent: Unit & " - " & Week (=B12 & " - " & C12)

区间数字格式是一致的:单位&“ - ”和周(= B12&“ - ”和C12)

• Interval Numbers are not longer than 31 character, and don't contain these special chars: [ ] / \ ? * .
  • If so, the sheet names will be shortened to 31 chars

  如果是这样,工作表名称将缩短为31个字符

  • and all special chars mentioned removed (Excel limitation for Sheet names)

  并删除了所有提到的特殊字符(工作表名称的Excel限制)

区间数不超过31个字符,并且不包含这些特殊字符:[] / \? *。如果是这样,工作表名称将缩短为31个字符,并删除所有提到的特殊字符(工作表名称的Excel限制)

• Working row starts after cell "Interval Number" and stop before "Vesting Doc Number (LC/RS)"

工作行在单元格“间隔编号”之后开始,并在“归属文档编号(LC / RS)”之前停止

• There are no spaces before or after "Interval Number" and "Vesting Doc Number (LC/RS)"

“Interval Number”和“Vesting Doc Number(LC / RS)”之前或之后没有空格

• Main tab name is exactly "Offshore Searches", and it contains only one button ("Create Tabs")

主选项卡名称正好是“离岸搜索”,它只包含一个按钮(“创建选项卡”)

1  

For what you have shown in the images, you may try something like this to achieve that...

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

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