我在 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
非常感谢您的帮助。
最佳答案
我采取了稍微不同的方法,但我已经实现了您正在寻找的结果。
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 列中的值用于重命名工作表,但不会在数据传输到新工作表时携带。
我不确定您希望如何处理已存在的同名工作表,但可以在重命名新工作表之前将其删除。
关于vba - 按空行拆分数据,并按原始数据集中的单元格值重命名新工作表,我们在Stack Overflow上找到一个类似的问题: https://stackoverflow.com/questions/30003799/