求教老师，保留表头拆分为多个文件的方法出现1004错误，求解决

网海遨游

Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    r = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row
    arr = ThisWorkbook.Sheets("Sheet1").Range("a1:u" & r)
    lc = UBound(arr, 2)
    Set rng = ThisWorkbook.Sheets("Sheet1").Range("a1:u5") '表头区域
    Set d = CreateObject("scripting.dictionary")
    For i = 6 To UBound(arr)
     If Not d.Exists(arr(i, 2)) Then
       Set d(arr(i, 2)) = ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Resize(1, lc)
     Else
       Set d(arr(i, 2)) = Union(d(arr(i, 2)), ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Resize(1, lc))
     End If
    Next
    k = d.Keys
    t = d.Items
    For i = 0 To d.Count - 1
     With Workbooks.Add
        rng.Copy .Sheets(1).[a1]
        t(i).Copy .Sheets(1).[a6]
        .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
        .Close
     End With
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕", 64, "提示"
End Sub

网海遨游

为防止重复提交而报错,再加一段.

Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    r = Cells(Rows.Count, 1).End(3).Row
    arr = ThisWorkbook.Sheets("Sheet1").Range("a1:u" & r)
    lc = UBound(arr, 2)
    Set rng = ThisWorkbook.Sheets("Sheet1").Range("a1:u5") '表头区域
    Set d = CreateObject("scripting.dictionary")
    For i = 6 To UBound(arr)
     If Not d.Exists(arr(i, 2)) Then
       Set d(arr(i, 2)) = ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Resize(1, lc)
     Else
       Set d(arr(i, 2)) = Union(d(arr(i, 2)), ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Resize(1, lc))
     End If
    Next
    k = d.Keys
    t = d.Items
    For i = 0 To d.Count - 1
      mf = Dir(ThisWorkbook.Path & "\*" & k(i) & "*.xls*")
      If mf = "" Then
     With Workbooks.Add
        rng.Copy .Sheets(1).[a1]
        t(i).Copy .Sheets(1).[a6]
        .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
        .Close
     End With
     Else
        Set dk = Workbooks.Open(ThisWorkbook.Path & "\" & mf)
        dk.Sheets(1).Cells.Clear
        rng.Copy dk.Sheets(1).[a1]
        t(i).Copy dk.Sheets(1).[a6]
        dk.Close True
      End If
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕", 64, "提示"
End Sub

网海遨游

这是附件,请测试.

haikeyia

能生成文件了，但仍提示错误，请教，如能标注说明，不胜感激！

网海遨游

我测试时，没有提示错误呀！

haikeyia

请教，调整为按其他列内容分表格，修改哪个参数，我是小白，请勿见笑

网海遨游

Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%,mf'定义变量类型
    Application.ScreenUpdating = False'禁屏幕刷新
    Application.DisplayAlerts = False'禁弹警告
    r = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(3).Row'A列有数据最大行号
    arr = ThisWorkbook.Sheets("Sheet1").Range("a1:u" & r)'给数组赋值
    lc = UBound(arr, 2)'列宽。你这里是21列
    Set rng = ThisWorkbook.Sheets("Sheet1").Range("a1:u5") '定义rng为表头区域
    Set d = CreateObject("scripting.dictionary")'定义字典
    For i = 6 To UBound(arr)'从第6行开始循环
     If Not d.Exists(arr(i, 2)) Then'若字典中无此关键字
       Set d(arr(i, 2)) = ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Resize(1, lc)'定义一个区域为字典关键字的条目
     Else'若有此关键字
       Set d(arr(i, 2)) = Union(d(arr(i, 2)), ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Resize(1, lc))'把姓名相同区城并起来
     End If
    Next
    k = d.Keys'字典关键字集合
    t = d.Items'字典关键字的条目集合
    For i = 0 To d.Count - 1
      mf = Dir(ThisWorkbook.Path & "\*" & k(i) & "*.xls*")'显示文件
      If mf = "" Then'若为空
     With Workbooks.Add'新建工作薄
        rng.Copy .Sheets(1).[a1]'复制粘贴标题
        t(i).Copy .Sheets(1).[a6]'复制粘贴数据
        .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"'保存指定名工作薄
        .Close'关闭
     End With
     Else'若有此工作薄
        Set dk = Workbooks.Open(ThisWorkbook.Path & "\" & mf)'打开工作薄
        dk.Sheets(1).Cells.Clear'请空数据
        rng.Copy dk.Sheets(1).[a1]'拷贝标题
        t(i).Copy dk.Sheets(1).[a6]'拷贝数据
        dk.Close True'关闭时保存更改
      End If
    Next
    Application.DisplayAlerts = True'允许警告
    Application.ScreenUpdating = True'允许屏幕刷新
    MsgBox "OK！完毕", 64, "提示"'提示完成
End Sub

蓝桥玄霜

应该按户主来分吧。

haikeyia

请教老师：
If Not d.Exists(arr(i, 2)) Then'这儿括号内的2是不是列关键字，我改成第一列然后不运行
       Set d(arr(i, 2)) = ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Resize(1, lc)'还有这行
     Else'若有些关键字
       Set d(arr(i, 2)) = Union(d(arr(i, 2)), ThisWorkbook.Sheets("Sheet1").Cells(i, 1).Resize(1, lc))'还有这行

haikeyia

蓝桥玄霜 发表于 2020-2-13 18:24
应该按户主来分吧。

老师，如果不分成文件内的sheet，而是分成多个单独的文件该如何操作呢？