Add a new row every time sheet is created

Question

I feel stupid I can't get it to work. After each sheet is created a blank row should automatically be inserted.

The intended outcome of the macro is to filter a specific column and create a new sheet for each of the filtered values.

Perhaps after the new sheets are created from the filtered values, a new row can be inserted for each of the new worksheets.

Can someone help modify it please?

Sub FilterData()
'DMT32 2017
    Dim ws1Master As Worksheet, wsNew As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range, objRange As Range
    Dim rowcount As Long
    Dim colcount As Integer, FilterCol As Integer, FilterRow As Long
    Dim SheetName As String, msg As String
    
    
'master sheet
    Set ws1Master = ActiveSheet
    
'select the Column filtering
top:
    On Error Resume Next
    Set objRange = Application.InputBox("Select Field Name To Filter", "Range Input", , , , , , 8)
    On Error GoTo 0
    If objRange Is Nothing Then
        Exit Sub
    ElseIf objRange.Columns.Count > 1 Then
        GoTo top
    End If
    
    FilterCol = objRange.Column
    FilterRow = objRange.Row
    
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    On Error GoTo progend
    
'add filter sheet
    Set wsFilter = Sheets.Add
    
    With ws1Master
        .Activate
        .Unprotect Password:=""  'add password if needed
        
        rowcount = .Cells(.Rows.Count, FilterCol).End(xlUp).Row
        colcount = .Cells(FilterRow, .Columns.Count).End(xlToLeft).Column
        
        If FilterCol > colcount Then
            Err.Raise 65000, "", "FilterCol Setting Is Outside Data Range.", "", 0
        End If
        
        Set Datarng = .Range(.Cells(FilterRow, 1), .Cells(rowcount, colcount))
        
'extract Unique values from FilterCol
        .Range(.Cells(FilterRow, FilterCol), .Cells(rowcount, FilterCol)).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=wsFilter.Range("A1"), Unique:=True
        
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
        
'set Criteria
        wsFilter.Range("B1").Value = wsFilter.Range("A1").Value
        
        For Each FilterRange In wsFilter.Range("A2:A" & rowcount)
            
'check for blank cell in range
            If Len(FilterRange.Value) > 0 Then
                
'add the FilterRange to criteria
                wsFilter.Range("B2").Value = FilterRange.Value
'ensure tab name limit not exceeded
                SheetName = Trim(Left(FilterRange.Value, 31))
                
'check if sheet exists
                On Error Resume Next
                Set wsNew = Worksheets(SheetName)
                If wsNew Is Nothing Then
'if not, add new sheet

                    Set wsNew = Sheets.Add(After:=Worksheets(Worksheets.Count))
                    wsNew.Name = SheetName
                Else
'clear existing data
                    wsNew.UsedRange.ClearContents
                End If
                On Error GoTo progend
'apply filter
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B1:B2"), _
                CopyToRange:=wsNew.Range("A1"), Unique:=False
                
            End If
            wsNew.UsedRange.Columns.AutoFit
            Set wsNew = Nothing
        Next
        
        .Select
    End With
    
    
progend:
    wsFilter.delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    
    If Err > 0 Then MsgBox (Error(Err)), 16, "Error"
End Sub

Add a new row every time sheet is created

0 Answers