按A列字段拆分工作表的问题

W773230386

我的工作表有42033行  A-M栏，用下面的折分代码进行拆分不了，请教高手，该代码不适用我的工作表么
Sub 拆分工作表()
'
Dim zROW As Integer, zHS As Integer
Dim I As Integer, J As Integer
Dim zNAME As String
Dim mYcell As Range

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    zNAME = ActiveSheet.Name
    For I = Sheets.Count To 1 Step -1
        Sheets(I).Select
        If ActiveSheet.Name <> zNAME Then ActiveWindow.SelectedSheets.Delete
    Next
    Application.DisplayAlerts = True
    zROW = Range("A1").End(xlDown).Row
    For I = 1 To zROW
        Rows(I & ":" & I).Copy
        zSELSHE (Cells(I, 1))
        Range("A65535").End(xlUp).Offset(1).Select
        If [A1] = "" Then Range("A1").Select
        ActiveSheet.Paste
        Sheets(zNAME).Select
    Next
    MsgBox "拆分工作完成。", vbInformation, "报告"
End Sub
Sub zSELSHE(zNAME As String)
    On Error GoTo zADD
    Sheets(zNAME).Select
    Exit Sub
zADD:
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = zNAME
    Sheets(zNAME).Select
End Sub

lpzxhjp

上传附件   

lzqmsy

Sub 分账()
Dim sh As Worksheet
Application.DisplayAlerts = False
For Each sh In Worksheets
    If sh.Name <> "明细账" Then
       sh.Delete
    End If
Next
Application.DisplayAlerts = True
AR = [A1].CurrentRegion
Set D = CreateObject("SCRIPTING.DICTIONARY")
For I = 2 To UBound(AR)
    D(AR(I, 1)) = ""
Next
K = D.KEYS
For I = 0 To D.Count - 1: ReDim BR(1 To UBound(AR), 1 To UBound(AR, 2)): L = 1
    For J = 2 To UBound(AR)
        If AR(J, 1) = K(I) Then
            L = L + 1
            For T = 1 To UBound(AR, 2)
                BR(L - 1, T) = AR(J, T)
            Next
        End If
    Next
crr = Range("A1", Cells(1, UBound(AR, 2)))
Sheets.Add AFTER:=Sheets(Sheets.Count)
Sheets(I + 2).Name = K(I)
Sheets(I + 2).[A1].Resize(1, UBound(BR, 2)) = crr
Sheets(I + 2).[A2].Resize(UBound(BR), UBound(BR, 2)) = BR
Next
End Sub