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
After :
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?
source to share
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 → Tools → References → 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")
source to share
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
source to share