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]

The macro appears to copy all rows not equivalent to a value in column D to a new sheet and names the sheet based on the rows it removed. Is that what you want it to do?

WBD

 

[VBA learner ITG]

Hi,

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:

THERE ISNT ENOUGH MEMORY TO COMPLETE THIS ACTION.
TRY USING LESS DATA OR CLOSING OTHER APPLICATIONS.
-USING A 64-BIT VERSION OF MICROSOFT EXCEL.
-ADDING MEMERORY TO YOUR DEVICE.

THEN STATES DEBUGGING MEMORY

THEN STATES "OUT OF MEMORY"


WHEN I GO TO DEBUG THIS IS THE LINE OF CODE IT SHOWS:

If Not rDelete Is Nothing Then rDelete.EntireRow.Delete

I MUST BE MISSING A CODE SOMEWHERE THAT CLEARS THE PROCESS AFTER EACH TAB. THAT I CANT FIND

 

[wideboydixon]

Try this which doesn't attempt to delete rows; it just filters them out before the copy:

Public Sub WBD20170822()

    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:="<>" & sNm
                    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,

Your amended code worked like a charm.

It has taken me a week to try and figure this out and you done it in a fraction of the time.

 

[VBA learner ITG]

Hi WBD,

I have the amended code and it now has a bug

the Tab names doesn't correspond with the Data that being created in the tab.

Any help would be appreciated.

 

[VBA learner ITG]

I tried to rename the new tabs with the below code so the data in the new tab is the same as the sheet name.

when running the code

ActiveSheet.Name = Range("D14").Value

 

[VBA learner ITG]

Can anyone advise how to get the tab name to correspond with the data being copied over.

 

[gallen]

Does this line in WBD's code not do what you ask? if not what is wrong? from where should the unique tab name be?

[COLOR=#333333] wsNew.Name = sNm[/COLOR]

 

[VBA learner ITG]

When i run the code:

The tab is called: EHL

Data pulled across

Record_ID	SEL_ID	Front_Back	Template_Type
0000001	0000001	F	Store
0000002	0000001	B	Store
0000003	0000002	F	Category
0000004	0000002	B	Category
0000017	0000009	F	SEL 0000145 F DST <tbody> </tbody>

<colgroup><col width="64" span="4" style="width:48pt"> </colgroup><tbody>
</tbody>

as you can see SEL is the unique value and the Tab is being called EHL

I also notice this line of code brings back other column cell value not unique as its showing DST as part of the EHL Tab

rData.AutoFilter Field:=4, Criteria1:="<>" & sNm