EXCEL xml+VBA智能数据拆分，部分自己用到的自定义函数，分享给大家

是 否 +2 论坛币

k人 参与回答

经管之家送您一份

应届毕业生专属福利!

求职就业群

赵安豆老师微信：zhaoandou666

经管之家联合CDA

送您一个全额奖学金名额~ !

立即领取

感谢您参与论坛问题回答

经管之家送您两个论坛币！

+2 论坛币

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

扫码加我 拉你入群

请注明：姓名-公司-职位

以便审核进群资格，未注明则拒绝

分享0 收藏6 回帖

关键词：EXCEL 自定义函数 xcel exce VBA 工作表 EXCEL Error 智能 样本

不知为何上述粘贴的代码显示有点乱，特地上传txt文档