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

指尖的阳光、

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

chxw68

修改好了。

赵桢0611

试试。。。。。。。

华发少年

拆分问题，给你一个工具吧， 下载就能用，
拆分工具之三 (20200926升级版）.rar (42.78 KB, 下载次数: 13)

2025-12-11 09:51 上传

点击文件名下载附件

ykcbf1100

新写一个吧。。。

ykcbf1100

1. Sub ykcbf()    ' 2025.12.11
   
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.     For Each k In d.Keys
    
34.         sh.Copy After:=wb.Sheets(wb.Sheets.Count)
    
35.         With wb.Sheets(wb.Sheets.Count)
    
36.             .Name = CStr(k)
    
37.             .DrawingObjects.Delete
    
38.             .UsedRange.Offset(bt).Clear
    
39.             rng.AutoFilter col, k
    
40.             rng.Offset(bt).Resize(rng.Rows.Count - bt).SpecialCells(xlCellTypeVisible).Copy .Range("A" & bt + 1)
    
41.         End With
    
42.         sh.AutoFilterMode = False
    
43.     Next k
    
44.     sh.Activate
    
45.     ApplicationSettings True
    
46.     If d.Count > 0 Then
    
47.         MsgBox "■ 拆分操作完成 ■" & vbCrLf & _
    
48.             "═══════════════════════" & vbCrLf & _
    
49.             "■ 处理时间: " & Format(Timer - tm, "0.000") & "秒" & vbCrLf & _
    
50.             "■ 处理行数: " & UBound(arr) - bt & "行" & vbCrLf & _
    
51.             "■ 生成表数: " & d.Count & "个" & vbCrLf & _
    
52.             "═══════════════════════", _
    
53.             vbInformation, "执行报告"
    
54.     End If
    
55. End Sub
    
56. 
    
57. Private Sub ApplicationSettings(ByVal Reset As Boolean)
    
58.     With Application
    
59.         .ScreenUpdating = Reset
    
60.         .DisplayAlerts = Reset
    
61.         .Calculation = IIf(Reset, xlCalculationAutomatic, xlCalculationManual)
    
62.         .AskToUpdateLinks = Reset
    
63.         .EnableEvents = Reset
    
64.     End With
    
65. End Sub
    
66. 
    

复制代码

指尖的阳光、

赵桢0611 发表于 2025-12-11 09:39
试试。。。。。。。

如果标题行是多行呢，比如3行或者4行，能否在代码中加入行数确定的代码？谢谢。

laoye5403

帮你改好了:
1\顺序错误
2\变量引用错误

cjc209

arr 表示数据数组 包含表头数据 "f1" 表示按第一列拆分 1为表头数 0为表位数 只需更改参数 薄内拆分成多表

cjc209

0 为表尾数