Help with VBA code

[VBA learner ITG]

I was wondering if i could get your advice.

I have the below code which works for copying and creating additional tabs by splitting values from a column into 2 tabs by applying a autofilter. However when it creates the 3rd tab it shows an error message that there is not enough memory to continue.

I think that the deleting hidden rows as part of the auto-filter is causing the code to fall down but i have tried to amend the code to clear memory etc but it keeps failing.

Can i please get your help!!

Option Explicit


'---------------------------------------------------------------------------------------
' Module    : Module1
' DateTime  : 24/09/2006 22:48
' Updated   : 2014
' Author    : Roy Cox (royUK)
' Website   :  more examples
' Purpose   :  Create a sheet for each unique name in data
' Disclaimer; This code is offered as is with no guarantees. You may use it in your
'             projects but please leave this header intact.
'---------------------------------------------------------------------------------------


Sub ExtractToSheets()
    Dim ws As Worksheet
    Dim wsNew As Worksheet
    Dim rData As Range, rList As Range, rDelete As Range
    Dim rCl As Range
    Dim sNm As String


    Const Crit1 As String = "Category"
    Const Crit2 As String = "Store"


    Set ws = Sheets("sheet1")
    On Error GoTo exit_Proc
    'extract a list of unique names
    'first clear existing list
    With ws
        Set rData = .Range("A1").CurrentRegion
        .Columns(.Columns.Count).Clear
        rData.Columns(4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True


        Set rList = .Cells(1, .Columns.Count).CurrentRegion
        Set rList = rList.Offset(1, 0).Resize(rList.Rows.Count - 1, _
                                              rList.Columns.Count)


        For Each rCl In rList
            sNm = rCl.Text


            ''///delete any previously created sheets(only if required-NB uses UDF)
            If WksExists(sNm) Then
                Application.DisplayAlerts = False
                Sheets(sNm).Delete
                Application.DisplayAlerts = True
            End If
            Select Case sNm
            Case "Store", "Category"
                ''/// ignore these names
            Case Else
                Sheets("sheet1").Copy After:=Worksheets(Worksheets.Count)
                With ActiveSheet
                    .Name = sNm


                    If Not .AutoFilterMode Then .Range("A1").AutoFilter
                    ActiveSheet.Range("$A$1:$L$206").AutoFilter Field:=4, Criteria1:="<>Store" _
                                                              , Operator:=xlAnd, Criteria2:="<>Category"
                    ActiveSheet.Range("$A$1:$L$206").AutoFilter Field:=4, Criteria1:=sNm


                    With Sheets(sNm).AutoFilter.Range
                        On Error Resume Next
                        Set rDelete = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
                                      .SpecialCells(xlCellTypeVisible)
                        On Error GoTo 0
                        If Not rDelete Is Nothing Then rDelete.EntireRow.Delete
                    End With
                    ''/// Remove the AutoFilter
                    .AutoFilterMode = False
                    .Range("A1").Select
                End With


            End Select


        Next rCl
    End With


    MsgBox "Report completed", vbInformation, "Done"
clean_up:
    ws.Columns(Columns.Count).ClearContents        'remove temporary list
    rData.AutoFilter        ''///switch off AutoFilter
    Exit Sub
exit_Proc:
    Application.ScreenUpdating = True
    Resume clean_up
End Sub








Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

 

[wideboydixon]

That's why I asked the original question about what the code does; it seemed to be the wrong logic. You replied with:

The macro works exactly as i need it to do apart from the error message that generates after the 2nd tab on the 3rd that states:

Your original code was set to remove each value from the list and name the tab accordingly. My code does exactly the same. I'm guessing you want to extract the unique values + Store/Category to each tab. I suggest you try this instead:

Public Sub WBD20170823()

    Dim ws As Worksheet
    Dim wsNew As Worksheet
    Dim rData As Range, rList As Range, rDelete As Range
    Dim rCl As Range
    Dim sNm As String

    ' Get handle to source sheet
    Set ws = Sheets("sheet1")
    
    ' Set up error handling
    ' On Error GoTo exit_Proc
    
    ' Work on source sheet
    With ws
        ' Get handle to source data range
        Set rData = .Range("A1").CurrentRegion
        
        ' Clear out the contents of the last column and copy unique values from column D there
        .Columns(.Columns.Count).Clear
        rData.Columns(4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Cells(1, .Columns.Count), Unique:=True

        ' Set the source for the unique list
        Set rList = .Cells(1, .Columns.Count).CurrentRegion
        Set rList = rList.Offset(1, 0).Resize(rList.Rows.Count - 1, rList.Columns.Count)
        
        ' Process all unique values
        For Each rCl In rList
            ' Get the unique value
            sNm = rCl.Text

            ' Remove previous sheet if it's there
            If WksExists(sNm) Then
                Application.DisplayAlerts = False
                Sheets(sNm).Delete
                Application.DisplayAlerts = True
            End If
            
            ' Now decide what to do
            Select Case sNm
                Case "Store", "Category"
                    ' Ignore these names
                Case Else
                    ' Add a new sheet
                    Set wsNew = Worksheets.Add(after:=Worksheets(Worksheets.Count))
                    wsNew.Name = sNm
                    
                    ' Filter the data and copy visible cells
                    rData.AutoFilter Field:=4, Criteria1:=Array(sNm, "Category", "Store"), Operator:=xlFilterValues
                    rData.SpecialCells(xlCellTypeVisible).Copy wsNew.Cells(1, 1)
            End Select
        Next rCl
    End With

    MsgBox "Report completed", vbInformation, "Done"
clean_up:
    ' Clean up the unique values column
    ws.Columns(Columns.Count).ClearContents
    
    ' Remove the auto filter
    rData.AutoFilter
    
    ' Activate the original sheet
    ws.Activate
    
    Exit Sub
    
exit_Proc:
    Application.ScreenUpdating = True
    Resume clean_up
End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

WBD

 

[VBA learner ITG]

Hi WBD,

I am sorry for for giving the incorrect information as i have been looking at this for 72 hours straight and cant see the woods for the trees.

I have tried your code and it works.

Thank you again for your help on this.

 

[VBA learner ITG]

Hi,

I am sorry to trouble you all again.

Is there a way to add the tab name with the "Category" & "Store" name after the filter is applied?

so if the tab name was dog it looks like below:

DOG_Category
DOG_Store


Is it even possible with this code because the auto filter is filtering the tab name and Category & Store each time?

 Filter the data and copy visible cells
                    rData.AutoFilter Field:=4, Criteria1:=Array(sNm, "Category", "Store"), Operator:=xlFilterValues
                    rData.SpecialCells(xlCellTypeVisible).Copy wsNew.Cells(1, 1)
            End Select
        Next rCl
    End With

 

[wideboydixon]

I'm not quite sure what you mean. How many tabs for each unique value do you want to create, what do you want to call them and what data should be on them?

WBD

 

[VBA learner ITG]

Hi Wbd,

re run your code above and for some reason this section of the code fails. When i look on other forums i see others have expressed the same issue.

Does it make a difference that I am running a 32 bit, windows 10 and running office 365 machine and not a 64bit?

Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

 

[VBA learner ITG]

I can confirm by the help of my peers on this site all I had to do is go into VBA - Tools -options - general - change to “Break on unhandled errors”.

it was due to a new installation of excel on my machine that had caused the code to generate an error.
I couldn’t have done it without the help of everyone.
I can’t thank everyone enough for their help!