根据空行分割工作簿为多个sheet

jshuanya

根据空行分割工作簿为多个sheet
有一个空行就拆分成一个表，可能有几十个空行，附件的文件只是截取了一部分


分割的sheet命名随意

jshuanya

用了以下代码有错误，只能分出来第一个空行前的，后面的空行没分出来。
Sub 按单元格区域拆分工作表()
    Dim wsSource As Worksheet,wsNew As Worksheet
    Dim rng As Range, cell As Range, isFirstCell As Boolean        
    Set wsSource = ThisWorkbook.Sheets("Sheet1") '设置待拆分的工作表
    isFirstCell = True ' 初始化为第一个单元格
    ' 遍历工作表的每一行
    For Each cell In wsSource.UsedRange.Rows
        ' 如果单元格不为空
        If Application.WorksheetFunction.CountA(cell) > 0 Then
            ' 如果是连续区域的第一个单元格
            If isFirstCell Then
                isFirstCell = False
                Set rng = cell ' 记录连续区域的起始单元格
            Else
                Set rng = Union(rng, cell) ' 将连续区域扩展
            End If      
        ElseIf Not isFirstCell Then  ' 如果遇到空行
            ' 复制连续区域到新工作表
            Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))
            rng.Copy wsNew.Range("A1")
            ' 以连续区域的第一个单元格的值命名新工作表
            wsNew.Name = rng.Cells(1, 1).Value
            Set rng = Nothing ' 重置区域变量
            isFirstCell = True ' 重置为第一个单元格
        End If
    Next cell
    ' 处理最后一个连续区域
    If Not rng Is Nothing Then
        Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))
        rng.Copy wsNew.Range("A1")
        wsNew.Name = rng.Cells(1, 1).Value
    End If
End Sub

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rn As Range
Dim sh As Worksheet
For Each sh In Sheets
    If sh.Index > 1 Then sh.Delete
Next sh
Set sht = Sheet1
With sht
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    ReDim rr(1 To r)
    n = 1
    rr(n) = 1
    For i = 2 To r
        If Trim(.Cells(i, 1)) = "" Then
            n = n + 1
            rr(n) = i
        End If
    Next i
    For i = 1 To n
        xh = rr(i)
        Set rn = .Cells(xh, 1).CurrentRegion
        ks = xh
        hs = rn.Rows.Count
        js = ks + hs - 1
        Set sh = Sheets.Add(after:=Sheets(Sheets.Count))
        .Rows(ks & ":" & js).Copy sh.[a1]
        sh.Name = i
    Next i
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "ok！"
End Sub

3190496160

分割表格测试.rar (25.35 KB, 下载次数: 3)

2024-10-30 09:41 上传

点击文件名下载附件

3190496160

代码仅仅给你提供一个思路而已，可能不完全啊符合你的需求

jshuanya

3190496160 发表于 2024-10-30 09:41
代码仅仅给你提供一个思路而已，可能不完全啊符合你的需求

谢谢。能否看一下我那段代码，好像是可以的，但是他sheet表名字相同就不行，会报错，然后带斜杠也会报错。

jshuanya

3190496160 发表于 2024-10-30 09:41
代码仅仅给你提供一个思路而已，可能不完全啊符合你的需求

能帮忙看一下我那个代码吗，好像是文件名错误停止了。不知道哪里有错误。我用一个小文件自建一些内容是可以运行没错误的，不知道怎么到这个表里就不对了。
Sub 按单元格区域拆分工作表()
    Dim wsSource As Worksheet,wsNew As Worksheet
    Dim rng As Range, cell As Range, isFirstCell As Boolean        
    Set wsSource = ThisWorkbook.Sheets("Sheet1") '设置待拆分的工作表
    isFirstCell = True ' 初始化为第一个单元格
    ' 遍历工作表的每一行
    For Each cell In wsSource.UsedRange.Rows
        ' 如果单元格不为空
        If Application.WorksheetFunction.CountA(cell) > 0 Then
            ' 如果是连续区域的第一个单元格
            If isFirstCell Then
                isFirstCell = False
                Set rng = cell ' 记录连续区域的起始单元格
            Else
                Set rng = Union(rng, cell) ' 将连续区域扩展
            End If      
        ElseIf Not isFirstCell Then  ' 如果遇到空行
            ' 复制连续区域到新工作表
            Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))
            rng.Copy wsNew.Range("A1")
            ' 以连续区域的第一个单元格的值命名新工作表
            wsNew.Name = rng.Cells(1, 1).Value
            Set rng = Nothing ' 重置区域变量
            isFirstCell = True ' 重置为第一个单元格
        End If
    Next cell
    ' 处理最后一个连续区域
    If Not rng Is Nothing Then
        Set wsNew = Sheets.Add(After:=Sheets(Sheets.Count))
        rng.Copy wsNew.Range("A1")
        wsNew.Name = rng.Cells(1, 1).Value
    End If
End Sub

3190496160

1、目前的代码效率很低的
2、目前的代码用每次取到的单元格区域的第一个单元格的值作为新的工作表的名称，但是，第一个单元格的值很多事相同的呀，

ykcbf1100

参与一下，分隔表格

ykcbf1100

按空行分隔。