Question

我需要根据工作表模板中的一系列单元格在工作簿中创建新选项卡。我还想删除与选项卡名称不匹配的数据行。例如，从下表中我会得到一个名为＆＃34; 2206 - 6＆＃34;并且只保留与之相关的数据，请记住，每次使用宏时，此范围的数据都会发生变化。

之前：

后：

区间数 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（＆＃34; Scripting.Dictionary＆＃34;）~~

早期绑定很快：VBA编辑器 - ＆gt; 工具 - ＆gt; 参考文献 - ＆gt;添加 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

假设

Interval Numbers格式是一致的：Unit＆amp; ＆＃34; - ＆＃34; ＆安培;周（= B12＆amp;＆＃34; - ＆＃34;＆amp; C12）
间隔号码不超过31个字符，并且不包含这些特殊字符：[] / \？ *。
- 如果是这样，工作表名称将缩短为31个字符
- 并删除了所有提到的特殊字符（工作表名称的Excel限制）
工作行在单元格＆＃34; Interval Number＆＃34;之后开始。＆＃34;归属文件编号（LC / RS）＆＃34;
＆＃34; Interval Number＆＃34;之前或之后没有空格和＆＃34;归属文件编号（LC / RS）＆＃34;
主要标签名称正是＆＃34;离岸搜索＆＃34;，它只包含一个按钮（＆＃34;创建标签＆＃34;）

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

2 个答案: