Question

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

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

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

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

我可以请你帮忙!!

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

我会删除“On Error Resume Next”语句并放入

msgbox(Err.Description)

在exit_Proc：handler下查看发生了什么。

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

1 个答案: