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

我在Sheet1设置了以下数据集标题，如下所示：

我想把大数据集分成不同的空行 。 每个数据集由一个空行分隔，每个数据集在A和E列的所有单元格中都有值，但是B ， C ， D列可能有一些空单元格是随机的。 所以要分割的定义元素是E列中的空行。
Q1：我想将标题A1：D1复制到新的工作表， 只复制列A：D而不是E列。
Q2：我想重新命名新的工作表，将列E中的单元格值作为他们的名字。

所以*结果如下：

工作表ID1 ：

工作表ID2 ：

工作表ID3 ：

我已经尝试了下面的代码，它的工作，但它只复制第一个表，而不重命名工作表取E列的单元格值，它应该复制列E，所以它应该只复制A：D ，它doesn通过所有表循环。

 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 

标题被存储以供重复使用，并且通过计数分隔空白行并加1来计数数据块的数量。 E列中的值用于重命名工作表，但不会在传送到新工作表的数据中执行。

我不知道如何处理一个已经存在的相同名称的工作表，但可以在新的工作表重命名之前删除它们。