求助vba代码，拆分内容有空行的工作表

贝贝数码

求助VBA代码，拆分内容有空行的工作表，内容是不规范的常规内容，但有唯一值（fapiao号码），有思路方法，根据fapiao号码，以18个fapiao号码为规则，内容需要包含最后一个fapiao号码下空白的小计行，然后拆分相关内容为到新表。新表复制1到4行的表头固定格式。拆分效果入拆分一、拆分二

jsgj2023

楼主发错版块了吧!

jsgj2023

Sub Adele()
    Dim d As Object
    Dim HeaderArea As Variant
    Dim kNum As Long
    Dim firstR As Long
    Dim endR As Long
    Dim yDel As Integer
    Dim ws As Worksheet
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For yDel = Sheets.Count To 4 Step -1
        Sheets(yDel).Delete
    Next yDel
    Application.DisplayAlerts = True
    Set d = CreateObject("scripting.dictionary")
    With Sheets("Sheet1")
    arr = .Range("a1").CurrentRegion
    For x = 5 To UBound(arr)
        If arr(x, 10) = "小计" Then
            If Not d.exists(arr(x, 10)) Then
                d(arr(x, 10)) = x
            Else
                d(arr(x, 10)) = d(arr(x, 10)) & "," & x
            End If
        End If
    Next x
    ar = d.items
    For y = 0 To UBound(ar): sr = Split(ar(y), ","): Next y
    ReDim er(1 To UBound(sr) + 1)
    For y = 0 To UBound(sr): k = k + 1: er(k) = sr(y) * 1: Next y
    End With
    For x = 1 To UBound(er) Step 18
        firstR = er(x) - 1
        endR = er(x + 17)
        kNum = kNum + 1
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = "拆分" & kNum
        Set ws = ActiveSheet
        With ws
            Sheets("Sheet1").Range("a1:r4").Copy .Range("a1")
            Sheets("Sheet1").Range("a" & firstR & ":" & "r" & endR).Copy .Range("a5")
        End With
    Next x
    Sheet1.Select
    Application.ScreenUpdating = True
End Sub

jsgj2023

Sub Adele()

jsgj2023

Sub Adele()
    Dim d As Object
    Dim HeaderArea As Variant
    Dim kNum As Long
    Dim firstR As Long
    Dim endR As Long
    Dim yDel As Integer
    Dim ws As Worksheet
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For yDel = Sheets.Count To 4 Step -1
        Sheets(yDel).Delete
    Next yDel
    Application.DisplayAlerts = True
    Set d = CreateObject("scripting.dictionary")
    With Sheets("Sheet1")
    arr = .Range("a1").CurrentRegion
    For x = 5 To UBound(arr)
        If arr(x, 10) = "小计" Then
            If Not d.exists(arr(x, 10)) Then
                d(arr(x, 10)) = x
            Else
                d(arr(x, 10)) = d(arr(x, 10)) & "," & x
            End If
        End If
    Next x
    ar = d.items
    For y = 0 To UBound(ar): sr = Split(ar(y), ","): Next y
    ReDim er(1 To UBound(sr) + 1)
    For y = 0 To UBound(sr): k = k + 1: er(k) = sr(y) * 1: Next y
    End With
    For x = 1 To UBound(er) Step 18
        firstR = er(x) - 1
        endR = er(x + 17)
        If Err.Number <> 0 Then endR = er(UBound(er))
        kNum = kNum + 1
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = "拆分" & kNum
        Set ws = ActiveSheet
        With ws
            Sheets("Sheet1").Range("a1:r4").Copy .Range("a1")
            Sheets("Sheet1").Range("a" & firstR & ":" & "r" & endR).Copy .Range("a5")
        End With
    Next x
    Sheet1.Select
    Application.ScreenUpdating = True
End Sub

jsgj2023

Sub Adele()

贝贝数码

感谢老师，老师太厉害了

贝贝数码

老师，如果以后数据升级了，格式表头改变了，代码如何修改请指教！！！谢谢了（现有表头是1到4行，共有18列），如果表头变成了6行，列数变成了20行，代码又需要修改，能否将代码修改成成灵活性的表头区域，和数据区域。

jsgj2023

Sub Adele()
    Dim d As Object
    Dim kNum As Long
    Dim firstR As Long
    Dim endR As Long
    Dim yDel As Integer
    Dim ws As Worksheet
    On Error Resume Next
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For yDel = Sheets.Count To 4 Step -1
        Sheets(yDel).Delete
    Next yDel
    Application.DisplayAlerts = True
    Set d = CreateObject("scripting.dictionary")
    With Sheets("Sheet1")
    r = .[a:a].Find(what:="发票代码").Row
    c = .Cells(r, Columns.Count).End(xlToLeft).Column
    arr = .Range("a1").CurrentRegion
    For x = 5 To UBound(arr)
        If arr(x, 10) = "小计" Then
            If Not d.exists(arr(x, 10)) Then
                d(arr(x, 10)) = x
            Else
                d(arr(x, 10)) = d(arr(x, 10)) & "," & x
            End If
        End If
    Next x
    ar = d.items
    For y = 0 To UBound(ar): sr = Split(ar(y), ","): Next y
    ReDim er(1 To UBound(sr) + 1)
    For y = 0 To UBound(sr): k = k + 1: er(k) = sr(y) * 1: Next y
    End With
    For x = 1 To UBound(er) Step 18
        firstR = er(x) - 1
        endR = er(x + 17)
        If Err.Number <> 0 Then endR = er(UBound(er))
        kNum = kNum + 1
        Sheets.Add(after:=Sheets(Sheets.Count)).Name = "拆分" & kNum
        Set ws = ActiveSheet
        With Sheets("Sheet1")
            .Range(.Cells(1, 1), .Cells(r, c)).Copy ws.Range("a1")
            .Range(.Cells(firstR, 1), .Cells(endR, c)).Copy ws.Range("a5")
        End With
    Next x
    Sheet1.Select
    Application.ScreenUpdating = True
End Sub

jsgj2023

Sub Adele()