VBA Advanced AutoFilter + Create New Sheets Based on Range

I need to create new tabs in a workbook based on a series of cells in a worksheet template. I also want to delete rows of data that do not match the tab name. For example, from the table below, I will have a new tab named "2206-6" and only the data associated with it will be saved, meaning that this data range will change every time the macro is used.

Before

enter image description here

After :

enter image description here


Interval number 2206 - 6 6304 - 5 4102 - 20

The table starts on line 11, but I need to keep all the information above. I have an advanced filter macro that is close to what I want, but it does two things that I don't need: creating blank tabs and not saving the information above line 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

      

I also have a macro that creates range based tabs with no advanced filter, so each tab looks identical (only the tab name changes)

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

      

Is there a way to create range based tabs while using the advanced filter at the same time?

+3


source to share


2 answers


Another option (tested)

All functions at the bottom, in a separate module
It copies the main sheet, removes the button and uses an automatic filter to remove unnecessary lines


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

Early binding quickly : VBA Editor → ToolsReferences → Add Lead time Microsoft Scripting


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

  • The format of the interval numbers is agreed: Unit and "-" and "Week" (= B12 and "-" and C12)
  • Interval numbers are no longer than 31 characters and do not contain these special characters: [] / \? *.
    • If so, sheet names will be abbreviated to 31 characters
    • and removed all special characters (Excel limitation for sheet names)
  • The operating line starts after the "Interval Number" cell and stops before the "Vesting Doc Number (LC / RS)"
  • No spaces before or after "Interval Number" and "Vesting Doc Number (LC / RS)"
  • The title of the main tab is "Offshore Searches" and it contains only one button ("Create Tabs")
+1


source


For what you showed in the images, you can try something like this to achieve this ...



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

      

+1


source







All Articles