多次查找字符拆分表格至簿内且修改表名为对应户主

3190496160

Sub 拆分()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sh In Sheets
    If sh.Index > 1 Then
        sh.Delete
    End If
Next sh
Application.DisplayAlerts = True
Set sh = Sheets("Table 1")
With sh
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    Dim rr()
    ReDim rr(1 To r)
    For i = 1 To r
        If InStr(.Cells(i, 1), "表一、基本信息") > 0 Then
            n = n + 1
            rr(n) = i
        End If
    Next i
    n = n + 1
    rr(n) = r
    If n = 1 Then MsgBox "找不到表一、基本信息标志！": End
    For i = 1 To n - 1
        ks = rr(i)
        If i < n - 1 Then
            js = rr(i + 1) - 1
        Else
            js = rr(i + 1)
        End If
        mc = .Cells(ks + 10, 2)
        sh.Copy after:=Sheets(Sheets.Count)
        With ActiveSheet
            .UsedRange.Clear
            sh.Rows(ks & ":" & js).Copy .[a1]
            .Name = mc
            For Each shp In .Shapes
                shp.Delete
            Next shp
        End With
    Next i
    .Select
End With
Application.ScreenUpdating = False
MsgBox "拆分完毕！"
End Sub

3190496160

3190496160

拆分表.rar (133.55 KB, 下载次数: 7)

2023-2-15 11:31 上传

点击文件名下载附件

3190496160

一楼附件中64行跟其他行不完全一致，已经帮你改过来了

cqcbc

ykcbf1100 发表于 2023-2-15 11:00
这个代码可以满足你的要求。

谢谢，对于我提供的表格可以完成，因为我删除了一些信息，实际上“序号”字样在到下一个标题行之间，是有重复的，只能通过我提示的N列“户主”单元格（精确匹配），确认户主姓名，但是我修改了一下，偏移没成功，希望大师修改一下。

cqcbc

3190496160 发表于 2023-2-15 11:31

感谢朱老师，拆分大师，完美解决。

ykcbf1100

cqcbc 发表于 2023-2-15 11:37
谢谢，对于我提供的表格可以完成，因为我删除了一些信息，实际上“序号”字样在到下一个标题行之间，是有 ...

那改用户主定位就可以了。

cqcbc

ykcbf1100 发表于 2023-2-15 13:01
那改用户主定位就可以了。

谢谢老师，完美了。也学习了如何定位。