vba - 按空行拆分数据，并按原始数据集中的单元格值重命名新工作表

Question

我在 Sheet1 中有以下数据集，其标题如下所示:

我想按每个空行将大数据集拆分为不同的工作表。每个数据集都由空行分隔，并且每个数据集在 A 和 E 列的所有单元格中都有值，但它们的 B 列除外， C、D 可能会随机出现一些空单元格。因此，要拆分的定义元素是 E 列中的空行。
Q1:我想将标题A1:D1复制到新工作表，并仅复制列A: D 而不是 E 列。
Q2:我想重命名新工作表，以将 E 列中的单元格值作为名称。

因此*结果如下:

工作表ID1:

工作表ID2:



工作表ID3:

我尝试过以下代码，它有效，但它只复制第一个表，而没有重命名工作表以获取 E 列中的单元格值，并且它应该复制列 E ，因此它应该只复制A:D，并且不会循环遍历所有表格。

Sub Split_Sheets_by_row()
    Dim lLoop As Long, lLoopStop As Long
    Dim rMove As Range, wsNew As Worksheet

    Set rMove = ActiveSheet.UsedRange.Columns("A:E")
    lLoopStop = WorksheetFunction.CountIf(rMove, "Heading5")
    For lLoop = 1 To lLoopStop
        Set wsNew = Sheets.Add
        rMove.Find("Heading5", rMove.Cells(1, 1), xlValues, _
        xlPart, , xlNext, False).CurrentRegion.Copy _
        Destination:=wsNew.Cells(1, 1)
    Next lLoop
End Sub

非常感谢您的帮助。

Answer 1

我采取了稍微不同的方法，但我已经实现了您正在寻找的结果。

Sub Split_Sheets_by_row()
    Dim hdr As Range, rng As Range, ws As Worksheet, wsn As Worksheet
    Dim rw As Long, lr As Long, b As Long, blks As Long

    Set ws = ActiveSheet
    With ws
        Set hdr = .Cells(1, 1).Resize(1, 4)
        lr = .Cells(Rows.Count, 5).End(xlUp).Row
        rw = 2
        blks = Application.CountBlank(.Range(.Cells(rw, 1), .Cells(lr, 1))) + 1
        For b = 1 To blks
            Set rng = .Cells(rw, 1).CurrentRegion
            Set rng = rng.Offset(-CBool(b = 1), 0).Resize(rng.Rows.Count + CBool(b = 1), 4)
            Set wsn = Worksheets.Add(after:=Sheets(Sheets.Count))
            With wsn
                .Name = rng.Offset(0, 4).Cells(1, 1).Value
                hdr.Copy Destination:=.Cells(1, 1)
                rng.Copy Destination:=.Cells(2, 1)
            End With
            rw = rw + rng.Rows.Count + 1
            Set rng = Nothing
            Set wsn = Nothing
            If rw > lr Then Exit For
        Next b
    End With
    Set rng = Nothing
    Set ws = Nothing

End Sub

存储 header 以供重复使用，通过计算分隔的空白行并添加1来计算数据 block 的数量。 E 列中的值用于重命名工作表，但不会在数据传输到新工作表时携带。

我不确定您希望如何处理已存在的同名工作表，但可以在重命名新工作表之前将其删除。