VBA learner ITG
Active Member
- Joined
- Apr 18, 2017
- Messages
- 272
- Office Version
- 365
- Platform
- Windows
- MacOS
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!!
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!!
Code:
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
