amend code already posted to divide sheets

[rjmdc]

posted by dmt32 a while back
how can i amend this code:
1- to automatically filter column B by heading
2- it crashes when re-run

Sub FilterData()
    'DMT32
    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


    'set the Column you
    'are 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 Filter 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.Clear
                    End If
                On Error GoTo progend
                'add / update
                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

 

[rjmdc]

says subscript out of range
i am using the full workbook not scrambled, the workbook i sent yu is a copy with hipaa names scrambled

 

[dmt32]

i pasted code into new module
then it crashed

Not sure what your issue is & can only conclude that you have other things going on in your workbook - can only suggest place copy of whole workbook in a dropbox & provide a link to it here.

Dave

 

[rjmdc]

when i do f8
ws data says variable not set

 

[dmt32]

when i do f8
ws data says variable not set

code works for me & with page you posted - something else going on in your workbook - place it in a dropbox

Dave

 

[rjmdc]

payments sample.xlsx

drive.google.com

this is an actual copy of the worksheet with privacy scrabmbled info

 

[dmt32]

this is an actual copy of the worksheet with privacy scrabmbled info

Sheet as published is not the problem - I run the code with it & have no issues - something else is going on in your workbook.


did you amended code to reflect name of your master sheet?

'your master sheet
    Set wsData = ThisWorkbook.Worksheets("Sheet1")

Dave

 

[rjmdc]

yes thats when it shuts down excel

 

[rjmdc]

i quit excel for now
i changed your sheet1 to name of sheet "All payments" and everytime i press run it shuts down excel and says critical error

 

[rjmdc]

what ese can i attempt

 

[dmt32]

i quit excel for now
i changed your sheet1 to name of sheet "All payments" and everytime i press run it shuts down excel and says critical error

All the code does is filter the master sheet by specified column & copy those values to either an existing sheet of the filtered name or one is created if it does not exist.
Other than changing sheet name, then assuming you have made no other changes to published code I have no further ideas why you have issues you report & would need to see a copy of the whole workbook to try & understand what is going on.

Dave