【解决问题】请看图
在原来的代码的基础上修改一下
【使用方法】
横全屏看效果更好哦
【代码】
代码语言：javascript复制 '把当前表拆分：一簿一表_to_多簿一表或一簿一表_to_一簿多表
'作者：哆哆
'时间：2023-05
Sub yhd_ExcelVBA_2拆分_一簿一表_to_多簿一表()
Dim title_row As Integer, RngCol As Range, split_Col As Integer
Dim dic As Object, ThisSht As Worksheet, i As Long, pathstr As String, YN As Integer
Dim newflag As Boolean, ThisWb As Workbook
Set dic = CreateObject("scripting.dictionary")
disAppSet (False)
On Error Resume Next
title_row = Application.InputBox(prompt:="请输入标题行数：", Type:=1)
Set RngCol = Application.InputBox(prompt:="请选择拆分的依据列", Default:=Selection.Address, Title:="选择", Type:=8)
If title_row = False Or RngCol = False Or title_row < 1 Then MsgBox "输入有误或选择空白区域，退了", 16, "哆哆提示": Exit Sub
YN = MsgBox("【是】:拆分在工作簿" & Chr(13) & Chr(13) & "【否】:拆分并新建工作簿", vbYesNo, "是否拆分在本工作簿") 'vbYes=6,vbNo=7
On Error GoTo 0 '以下恢复捕捉代码出现错误消息
t = Timer
newflag = YN - 6
split_Col = RngCol.Column
pathstr = ThisWorkbook.Path & "拆分结果"
If Dir(pathstr, vbDirectory) = "" Then MkDir pathstr
Set ThisSht = ActiveSheet
With ThisSht
lastrow = .Cells.Find("*", , , , 1, 2).Row
For i = title_row 1 To lastrow
s = Trim(.Cells(i, split_Col))
If s <> "" Then
dic(s) = IIf(dic.exists(s), dic(s) & "_" & i, i)
End If
Next i
End With
For j = 0 To dic.Count - 1
If newflag Then '0拆分在本工作簿1拆分并新建工作簿
Set ThisWb = Workbooks.Add
Else
Set ThisWb = ThisWorkbook
End If
Set addSht = ThisWb.Worksheets.Add(After:=ThisWb.Worksheets(ThisWb.Worksheets.Count))
With addSht
ThisSht.Cells(1, 1).Resize(title_row, 1).EntireRow.Copy .Cells(1, 1)
cc = VBA.Split(dic.items()(j), "_")
Set ran = ThisSht.Rows(cc(0))
For i = 1 To UBound(cc)
If cc(i) <> "" Then
Set ran = Application.Union(ran, ThisSht.Rows(cc(i)))
End If
Next i
ran.Copy
.Cells(title_row 1, 1).Select
Selection.PasteSpecial Paste:=xlPasteFormulasAndNumberFormats
Selection.PasteSpecial Paste:=xlPasteFormats
For Each shp In .Shapes
shp.Delete
Next shp
.Cells(1, 1).Select
.Name = dic.keys()(j)
End With
If newflag Then
ThisWb.SaveAs pathstr & dic.keys()(j)
ThisWb.Close True
Else
ThisWb.Save
End If
Set ThisWb = Nothing
Next j
disAppSet (True)
MsgBox "拆分" & dic.Count & "个，用时：" & Format(Timer - t, "0.00秒")
End Sub
'用法：disAppSet(true)开disAppSet(true)关
Sub disAppSet(flag As Boolean)
With Application
.ScreenUpdating = flag
.DisplayAlerts = flag
.AskToUpdateLinks = flag
If flag Then
.Calculation = xlCalculationAutomatic
Else
.Calculation = xlCalculationManual
End If
End With
End Sub
如果对你有帮助，请转发给更多人免费使用哦！
