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

ykcbf1100

再简化一下操作，不用去输入拆分列号和标题行号了，直接用鼠标点选标题行拆分列单元格即可自动获取标题行号和拆分列号。

对于此题，鼠标点选A1单元格即可以完成对A列的拆分。不过，对于B~J列，要点选标题行第2行的单元格才行。

ykcbf1100

1. Sub ykcbf()    ' 2025.12.12
   
2.     ApplicationSettings False
   
3.     Set wb = ThisWorkbook
   
4.     Set sh = wb.Sheets(1)
   
5.     With sh
   
6.         If .AutoFilterMode Then .AutoFilterMode = False
   
7.         Set MyRange = Application.InputBox( _
   
8.             Prompt:="请用鼠标点选标题行拆分列单元格（标题行的最大行），然后单击确定按钮。", _
   
9.             Title:="选择标题行拆分列单元格", _
   
10.             Type:=8)
    
11.         If MyRange Is Nothing Then Exit Sub
    
12.         col = MyRange.Column
    
13.         bt = MyRange.MergeArea.Rows.Count + MyRange.Row - 1
    
14.         r = .Cells(.Rows.Count, col).End(xlUp).Row
    
15.         c = .Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
    
16.         Set Rng = .[A1].Resize(r, c)
    
17.         arr = Rng.Value
    
18.     End With
    
19.     tm = Timer
    
20.     Dim idx As Long
    
21.     If wb.Sheets.Count > 1 Then
    
22.         For idx = wb.Sheets.Count To 1 Step -1
    
23.             If wb.Sheets(idx).Name <> sh.Name Then
    
24.                 wb.Sheets(idx).Delete
    
25.             End If
    
26.         Next idx
    
27.     End If
    
28.     Set d = CreateObject("Scripting.Dictionary")
    
29.     If col <= UBound(arr, 2) Then
    
30.         For i = bt + 1 To UBound(arr, 1)
    
31.             v = arr(i, col)
    
32.             If Len(Trim(CStr(v))) > 0 Then
    
33.                 If Not d.Exists(v) Then d(v) = True
    
34.             End If
    
35.         Next i
    
36.     End If
    
37.     On Error Resume Next
    
38.     For Each k In d.Keys
    
39.         Rng.AutoFilter col, k
    
40.         sh.Copy After:=wb.Sheets(wb.Sheets.Count)
    
41.         With wb.Sheets(wb.Sheets.Count)
    
42.             .Name = CleanSheetName(CStr(k))
    
43.             .DrawingObjects.Delete
    
44.             .AutoFilterMode = False
    
45.             .UsedRange.Offset(bt).Clear
    
46.             Rng.Offset(bt).Resize(Rng.Rows.Count - bt).SpecialCells(xlCellTypeVisible).Copy .Range("A" & bt + 1)
    
47.         End With
    
48.     Next k
    
49.     sh.Activate
    
50.     sh.AutoFilterMode = False
    
51.     ApplicationSettings True
    
52.     If d.Count > 0 Then
    
53.         MsgBox "■ 拆分操作完成 ■" & vbCrLf & _
    
54.             "═══════════════════════" & vbCrLf & _
    
55.             "■ 处理时间: " & Format(Timer - tm, "0.000") & "秒" & vbCrLf & _
    
56.             "■ 处理行数: " & UBound(arr) - bt & "行" & vbCrLf & _
    
57.             "■ 生成表数: " & d.Count & "个" & vbCrLf & _
    
58.             "═══════════════════════", _
    
59.             vbInformation, "执行报告"
    
60.     End If
    
61. End Sub
    
62. 
    
63. Private Sub ApplicationSettings(ByVal Reset As Boolean)
    
64.     With Application
    
65.         .ScreenUpdating = Reset
    
66.         .DisplayAlerts = Reset
    
67.         .Calculation = IIf(Reset, xlCalculationAutomatic, xlCalculationManual)
    
68.         .AskToUpdateLinks = Reset
    
69.         .EnableEvents = Reset
    
70.     End With
    
71. End Sub

复制代码

386026398

ykcbf1100 发表于 2025-12-12 09:39
不是我的代码有问题，而是你修改了我的代码造成的。这里的标题行是2行，输入时要输入2

你用AI修改代码 ...

谢谢分享，我正需要这个，操作简单方便。