按列拆分，请看看怎么修改？谢谢。

cjc209

秒拆分  参数根据具体情况填写 拆分列可以为多列

qdchyq

Sub 按户号拆分工作簿()
    Dim wsSource As Worksheet
    Dim wbNew As Workbook
    Dim wsNew As Worksheet
    Dim i As Long, startRow As Long, endRow As Long
    Dim householdID As String, prevHouseholdID As String
    Dim headerRows As Integer, footerStartRow As Integer, dataEndRow As Integer
    Dim outputPath As String, validSheetName As String
    Dim dataCol As Integer
    Dim illegalChars As Variant
   
    ' ===================== 基础配置（重点：限定37行数据） =====================
    Set wsSource = ThisWorkbook.Worksheets("数据") ' 原始工作表名称
    headerRows = 6 ' 表头行数（1-6行）
    dataEndRow = 37 ' 数据结束行（固定到37行，户号仅在7-37行）
    footerStartRow = 38 ' 表尾开始行（38-42行，与数据区分离）
    outputPath = ThisWorkbook.Path & "\按户号拆分结果\" ' 输出路径
    dataCol = 1 ' 户号列（A=1，B=2...）
    illegalChars = Array("\", "/", "?", "*", "[", "]", ":") ' Excel非法字符列表
   
    ' 户号列设为文本格式（防止前置0丢失）
    wsSource.Columns(dataCol).NumberFormat = "@"
    ' 创建输出文件夹（不存在则新建）
    If Dir(outputPath, vbDirectory) = "" Then MkDir outputPath
   
    ' ===================== 初始化变量 =====================
    prevHouseholdID = ""
    startRow = headerRows + 1 ' 数据开始行（7行，表头后第一行）
   
    ' ===================== 遍历37行数据拆分 =====================
    ' 仅遍历7-37行（startRow到dataEndRow），不涉及表尾
    For i = startRow To dataEndRow
        ' 获取文本格式户号（避免数字解析错误）
        householdID = Trim(CStr(wsSource.Cells(i, dataCol).Value))
        
        ' 拆分触发条件：1.户号变化 2.到达37行（数据最后一行）
        If (householdID <> prevHouseholdID And i > startRow) Or i = dataEndRow Then
            ' 确定当前户号数据结束行
            If i = dataEndRow Then
                endRow = i
            Else
                endRow = i - 1
            End If
            
            ' 只处理有效户号（跳过空值）
            If prevHouseholdID <> "" Then
                ' 1. 生成合法工作表名称（解决命名错误）
                validSheetName = GetValidSheetName(prevHouseholdID, illegalChars)
               
                ' 2. 创建新工作簿
                Set wbNew = Workbooks.Add
                Set wsNew = wbNew.Worksheets(1)
                wsNew.Name = validSheetName ' 赋值合法名称
               
                ' 3. 复制表头（1-6行，含格式）
                wsSource.Rows("1:" & headerRows).Copy
                wsNew.Rows("1:" & headerRows).PasteSpecial Paste:=xlPasteAll
                Application.CutCopyMode = False
               
                ' 4. 复制当前户号数据（7-37行内的对应行，文本格式）
                wsNew.Columns(dataCol).NumberFormat = "@" ' 新表户号列先设文本
                wsSource.Rows(startRow & ":" & endRow).Copy
                wsNew.Rows(headerRows + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
                Application.CutCopyMode = False
               
                ' 5. 复制表尾（38-42行，完整保留）
                Dim newDataLastRow As Long
                newDataLastRow = wsNew.Cells(wsNew.Rows.Count, dataCol).End(xlUp).Row ' 新表数据最后一行
                wsSource.Rows(footerStartRow & ":" & footerStartRow + 4).Copy ' 38-42行共5行
                wsNew.Rows(newDataLastRow + 1).PasteSpecial Paste:=xlPasteAll
                Application.CutCopyMode = False
               
                ' 6. 保存新工作簿
                wbNew.SaveAs _
                    fileName:=outputPath & validSheetName & "_数据.xlsx", _
                    FileFormat:=xlOpenXMLWorkbook
                wbNew.Close SaveChanges:=False
               
                Debug.Print "已生成：" & validSheetName & "_数据.xlsx（数据范围：" & startRow & "-" & endRow & "行）"
            End If
            
            ' 更新变量，准备下一户号
            prevHouseholdID = householdID
            startRow = i
        End If
    Next i
   
    ' ===================== 完成提示 =====================
    MsgBox "拆分完成！" & vbCrLf & _
           "1. 数据范围：仅7-37行户号数据" & vbCrLf & _
           "2. 包含内容：前6行表头+38-42行表尾" & vbCrLf & _
           "3. 保存路径：" & outputPath, vbInformation
   
    ' 清理对象（释放内存）
    Set wsNew = Nothing: Set wbNew = Nothing: Set wsSource = Nothing
End Sub

' 【辅助函数】生成合法Excel工作表名称（解决命名错误）
Function GetValidSheetName(originalName As String, illegalChars As Variant) As String
    Dim validName As String
    Dim char As Variant
    Dim maxLen As Integer
   
    maxLen = 31 ' Excel工作表名称最大长度
    validName = originalName
   
    ' 1. 过滤非法字符（替换为“-”）
    For Each char In illegalChars
        validName = Replace(validName, char, "-")
    Next char
   
    ' 2. 处理空值户号
    If Trim(validName) = "" Then
        validName = "无户号数据"
    Else
        ' 3. 截断超长名称（保留前27字符+“...”，总长度≤31）
        If Len(validName) > maxLen - 4 Then
            validName = Left(validName, maxLen - 4) & "..."
        End If
        ' 4. 加前缀“户号_”（标识清晰）
        validName = "户号_" & validName
    End If
   
    GetValidSheetName = validName
End Function

指尖的阳光、

ykcbf1100 发表于 2025-12-11 09:58

生成的子表中，怎么有空白行，怎么解决

ykcbf1100

指尖的阳光、 发表于 2025-12-11 15:23
生成的子表中，怎么有空白行，怎么解决

我上传的附件没有问题的。
你把有问题的附件发上来看一下。

半百

修改以下几处看看

今铭昔

赵桢0611

多标题行及选择标题行

指尖的阳光、

ykcbf1100 发表于 2025-12-11 15:40
我上传的附件没有问题的。
你把有问题的附件发上来看一下。

请看一下，如何修改。

ykcbf1100

指尖的阳光、 发表于 2025-12-12 08:43
请看一下，如何修改。

不是我的代码有问题，而是你修改了我的代码造成的。这里的标题行是2行，输入时要输入2

你用AI修改代码，最后的结果并不一定对，你不要太相信AI，目前的AI还不太成熟。

ykcbf1100

1. Sub ykcbf()    ' 2025.12.12
   
2.     ApplicationSettings False
   
3.     col = Val(Application.InputBox("请输入拆分列列号：默认是1列", "拆分依据列列号", 1))
   
4.     bt = Val(Application.InputBox("请输入标题行数：默认是1行", "标题行数", 1))
   
5.     If col = 0 Or bt = 0 Then Exit Sub
   
6.     Set wb = ThisWorkbook
   
7.     Set sh = wb.Sheets(1)
   
8.     tm = Timer
   
9.     With sh
   
10.         If .AutoFilterMode Then .AutoFilterMode = False
    
11.         r = .Cells(.Rows.Count, col).End(xlUp).Row
    
12.         c = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    
13.         Set rng = .[A1].Resize(r, c)
    
14.         arr = rng.Value
    
15.     End With
    
16.     Dim idx As Long
    
17.     If wb.Sheets.Count > 1 Then
    
18.         For idx = wb.Sheets.Count To 1 Step -1
    
19.             If wb.Sheets(idx).Name <> sh.Name Then
    
20.                 wb.Sheets(idx).Delete
    
21.             End If
    
22.         Next idx
    
23.     End If
    
24.     Set d = CreateObject("Scripting.Dictionary")
    
25.     If col <= UBound(arr, 2) Then
    
26.         For i = bt + 1 To UBound(arr, 1)
    
27.             v = arr(i, col)
    
28.             If Len(Trim(CStr(v))) > 0 Then
    
29.                 If Not d.Exists(v) Then d(v) = True
    
30.             End If
    
31.         Next i
    
32.     End If
    
33.     On Error Resume Next
    
34.     For Each k In d.Keys
    
35.         sh.Copy After:=wb.Sheets(wb.Sheets.Count)
    
36.         With wb.Sheets(wb.Sheets.Count)
    
37.             .Name = CleanSheetName(CStr(k))
    
38.             .DrawingObjects.Delete
    
39.             .UsedRange.Offset(bt).Clear
    
40.             rng.AutoFilter col, k
    
41.             rng.Offset(bt).Resize(rng.Rows.Count - bt).SpecialCells(xlCellTypeVisible).Copy .Range("A" & bt + 1)
    
42.         End With
    
43.         sh.AutoFilterMode = False
    
44.     Next k
    
45.     sh.Activate
    
46.     ApplicationSettings True
    
47.     If d.Count > 0 Then
    
48.         MsgBox "■ 拆分操作完成 ■" & vbCrLf & _
    
49.             "═══════════════════════" & vbCrLf & _
    
50.             "■ 处理时间: " & Format(Timer - tm, "0.000") & "秒" & vbCrLf & _
    
51.             "■ 处理行数: " & UBound(arr) - bt & "行" & vbCrLf & _
    
52.             "■ 生成表数: " & d.Count & "个" & vbCrLf & _
    
53.             "═══════════════════════", _
    
54.             vbInformation, "执行报告"
    
55.     End If
    
56. End Sub
    
57. 
    
58. Private Sub ApplicationSettings(ByVal Reset As Boolean)
    
59.     With Application
    
60.         .ScreenUpdating = Reset
    
61.         .DisplayAlerts = Reset
    
62.         .Calculation = IIf(Reset, xlCalculationAutomatic, xlCalculationManual)
    
63.         .AskToUpdateLinks = Reset
    
64.         .EnableEvents = Reset
    
65.     End With
    
66. End Sub
    
67. 
    
68. ' 清理非法工作表名称字符
    
69. Function CleanSheetName(str As String) As String
    
70.     Dim illegalChars As String
    
71.     illegalChars = ":\/?*[]"
    
72.     For i = 1 To Len(illegalChars)
    
73.         str = Replace(str, Mid(illegalChars, i, 1), "_")
    
74.     Next i
    
75.     CleanSheetName = Left(Trim(str), 31)  ' 限制长度
    
76. End Function

复制代码