复制粘贴时删除模块中的强制声明语句，代码显示有点乱，需要的直接下载1楼的txt附件















Sub 子样本工作表拆分()
Application.DisplayAlerts = False
On Error Resume Next
Dim tit As Range, rngs As Range, subrng As RangeDim pah$, ar, rng As Range, rng1 As Range, numrow%
Dim rngg As Range, wb As Workbook
Dim wsname$, cel As Range, savename$
wsname = ActiveSheet.Name
Set tit = Application.InputBox("请选择表头区域", "表头", , , , , , 8)
If tit Is Nothing Then End
Set rngs = Application.InputBox("请选择拆分区域", "数据", , , , , , 8)
If rngs Is Nothing Then End
Set subrng = Application.InputBox("请选择拆分列", "拆分列", , , , , , 8)
If subrng Is Nothing Then End
Application.FileDialog(msoFileDialogFolderPicker).Title = "保存路径"
Application.FileDialog(msoFileDialogFolderPicker).Show
pah = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\"
If pah = "" Then End
Set d = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
For Each rng In Intersect(rngs, subrng.EntireColumn)
If rng.Value <> "" Then d(rng.Value) = ""
Next
For Each ar In d.keys
Set rng1 = subrng.EntireColumn.Find(ar)
numrow = WorksheetFunction.CountIf(Intersect(rngs, Columns(subrng.Column)), ar)
Set rngg = Intersect(rng1.EntireRow, rngs).Range("a1").Resize(numrow, rngs.Columns.Count)

savename = WorksheetFunction.Substitute(ar, "/", "-")
Set wb = Workbooks.Open(pah & savename)
If wb Is Nothing Then Set wb = Workbooks.Add
wb.Worksheets.Add.Name = wsname
With wb.Worksheets(1)
Set cel = .Range("a" & tit.Rows.Count + 1)
.Activate
.Name = wsname
tit.Copy
.Range("a1").PasteSpecial xlPasteValues
.Range("a1").PasteSpecial xlPasteFormats
rngg.Copy
cel.PasteSpecial xlPasteValues
cel.PasteSpecial xlPasteColumnWidths
cel.PasteSpecial xlPasteFormats
End With
wb.SaveAs pah & savename
wb.Close
Set wb = Nothing
'If Err.Number > 0 Then MsgBox "数据处理不合规，请确定后尝试!", vbOKOnly, "错误提示": Exit Sub
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub