复制粘贴时删除模块中的强制声明语句，代码显示有点乱，需要的直接下载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