stop add new sheet when split data into multiple sheets when run macro repeatedly

[Hasson]

hi
I got this code from this forum. it works well . it split based on column B and update the data for each sheet has ever splited, but the problem is create new sheet when run the macro repeatedly . the sheet seems to be necessary . I no know if threre is way to get rid of this thing . any idea experts?

Option Explicit
Sub FilterColumn()
    
    Dim wsData As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng As Range, FilterRange As Range
    Dim rowcount As Long
    Dim FilterCol As Variant
    Dim SheetName As String
  
    
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
    FilterCol = "B"
  
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
    Set wsFilter = ThisWorkbook.Worksheets.Add
  
    With wsData
        .Activate
        .Unprotect Password:=""
      
        Set Datarng = .Range("A2").CurrentRegion
      
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=wsFilter.Range("A2"), Unique:=True
      
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row

        wsFilter.Range("B2").Value = wsFilter.Range("A2").Value
      
        For Each FilterRange In wsFilter.Range("A3:A" & rowcount)
            SheetName = CStr(Left(FilterRange.Text, 31))
            If SheetName <> "" Then

            
                wsFilter.Range("B3").Formula = "=" & """=" & SheetName & """"

                If Not Evaluate("ISREF('" & SheetName & "'!A2)") Then

                    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
                End If

                Set wsNames = Worksheets(SheetName)

                wsNames.UsedRange.Clear

                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B2:B3"), _
                CopyToRange:=wsNames.Range("A1"), Unique:=False
            End If

            Datarng.Rows(1).Copy
            wsNames.UsedRange.Rows(1).PasteSpecial xlPasteColumnWidths

            Set wsNames = Nothing

            Application.CutCopyMode = False
        Next
        .Select
    End With
  
      
End Sub

 

[dmt32]

Hi,
that looks very much like one of my codes someone has modified.
There is some code missing at the end that handles errors & deletes the filter sheet

Add codes shown in BOLD & see if resolves your issue

Option Explicit
Sub FilterColumn()
    
    Dim wsData      As Worksheet, wsNames As Worksheet, wsFilter As Worksheet
    Dim Datarng     As Range, FilterRange As Range
    Dim rowcount    As Long
    Dim FilterCol   As Variant
    Dim SheetName   As String
    
    On Error GoTo myerror
    
    Set wsData = ThisWorkbook.Worksheets("Sheet1")
    FilterCol = "B"
    
    With Application
        .ScreenUpdating = False: .DisplayAlerts = False
    End With
    Set wsFilter = ThisWorkbook.Worksheets.Add
    
    With wsData
        .Activate
        .Unprotect Password:=""
        
        Set Datarng = .Range("A2").CurrentRegion
        
        .Cells(1, FilterCol).Resize(Datarng.Rows.Count).AdvancedFilter Action:=xlFilterCopy, _
                  CopyToRange:=wsFilter.Range("A2"), Unique:=True
        
        rowcount = wsFilter.Cells(wsFilter.Rows.Count, "A").End(xlUp).Row
        
        wsFilter.Range("B2").Value = wsFilter.Range("A2").Value
        
        For Each FilterRange In wsFilter.Range("A3:A" & rowcount)
            SheetName = CStr(Left(FilterRange.Text, 31))
            If SheetName <> "" Then
                
                wsFilter.Range("B3").Formula = "=" & """=" & SheetName & """"
                
                If Not Evaluate("ISREF('" & SheetName & "'!A1)") Then
                    
                    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = SheetName
                End If
                
                Set wsNames = Worksheets(SheetName)
                
                wsNames.UsedRange.Clear
                
                Datarng.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wsFilter.Range("B2:B3"), _
                                       CopyToRange:=wsNames.Range("A1"), Unique:=False
            End If
            
            Datarng.Rows(1).Copy
            wsNames.UsedRange.Rows(1).PasteSpecial xlPasteColumnWidths
            
            Set wsNames = Nothing
            
            Application.CutCopyMode = False
        Next
        .Select
    End With
    
myerror:
    If Not wsFilter Is Nothing Then wsFilter.Delete
    With Application
        .ScreenUpdating = True: .DisplayAlerts = True
    End With
    
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
    
End Sub

Dave

 

[Hasson]

that looks very much like one of my codes

you're right. this is yours

someone has modified

I suspect that. this is from your designing as far as I know , Unfortunately I have no link . this code has been taken from long time and now I would use it , but I 've found it should mod .

Add codes shown in BOLD & see if resolves your issue

! it works
thanks so much

 

[dmt32]

! it works
thanks so much

you are welcome glad resolved - appreciate the feedback

Dave