Excel VBA复制和粘贴选项卡，并通过自动过滤和删除隐藏的行错误消息内存不足

Question

我想知道我是否可以得到你的建议。

我有下面的代码，它通过将列中的值拆分为 2 个选项卡来复制和创建其他选项卡，并在每个选项卡上应用自动过滤器。

但是，当它创建第三个选项卡时，它会显示一条错误消息，指出没有足够的内存继续。

我认为作为自动过滤器的一部分删除隐藏的行会导致代码下降，但我试图修改代码以清除内存等，但它一直失败。

我能得到你的帮助吗！！

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

Answer 1

我会删除"出错时恢复下一个"语句并放置

msgbox(Err.Description)

在 exit_Proc： 处理程序下查看发生了什么。