把Excel一个工作表拆分成多个工作表的代码出现bug，求大神帮忙修复下

星梦月缘

各位大神好，我经常用的把把Excel一个工作表拆分成多个工作表的代码出现bug了，拆分的过程是用的筛选拆分的，之前用着一直都挺好用的，
今天由于数据源的变化，导致拆分过程中报错，详细报错内容见截图所示，想请大神给帮忙看看为什么会出现这个报错，顺便帮忙给修复下这个bug，非常感谢了，文件也已经同步上传附件了。

wang-way

你应该 改用 usedrange.specialCells(xlcelltypeVisible)这个

3190496160

Sub mf()
Application.ScreenUpdating = False
Dim sht As Worksheet
Dim i As Integer
Dim ar As Variant
Dim rng As Range
Dim d As Object
Set d = CreateObject("scripting.dictionary")
t = Timer
Application.DisplayAlerts = False
For Each sht In Sheets
    If sht.Name <> "总表" And sht.Name <> "辅助表" Then
        sht.Delete
    End If
Next
Application.DisplayAlerts = True
ar = Sheets("总表").[a1].CurrentRegion
For i = 2 To UBound(ar)
    If Trim(ar(i, 7)) <> "" Then
        d(Trim(ar(i, 7))) = ""
    End If
Next i
For Each k In d.keys
    Sheets("总表").Copy after:=Sheets(Sheets.Count)
    With Sheets(Sheets.Count)
        .Name = k
        For i = 2 To UBound(ar)
            If Trim(.Cells(i, 7)) <> k Then
                If rng Is Nothing Then
                    Set rng = .Rows(i)
                Else
                    Set rng = Union(rng, .Rows(i))
                End If
            End If
        Next i
        If Not rng Is Nothing Then rng.Delete
        For Each sp In .Shapes
            sp.Delete
        Next sp
    End With
    Set rng = Nothing
Next k
Set d = Nothing
Set rng = Nothing
Application.ScreenUpdating = True
MsgBox "表格拆分完毕，耗时：" & Format(Timer - t, "0.00") & "秒", 64, "提醒"
End Sub

3190496160

求助表.rar (307.71 KB, 下载次数: 3)

2021-4-14 22:56 上传

点击文件名下载附件

3190496160

原来的代码思路欠佳，效率不高的，帮你重新写了一下，自己测试看看吧，目前的代码拆分结果可以完全保留元工作表的所有结构，包括页面设置等等
其实，楼主也去我的主题里面去找找，几个拆分工具，一定有一个适合您的

星梦月缘

wang-way 发表于 2021-4-14 22:33
你应该 改用 usedrange.specialCells(xlcelltypeVisible)这个

谢谢老师，请问下为什么用Sheet1.Range("a1:h" & irow).Copy Sheets(j).Range("a1")  用这个代码就会报错呢？是因为合并单元格的问题吗？
有的可以成功复制，有的不能复制。

星梦月缘

3190496160 发表于 2021-4-14 22:58
原来的代码思路欠佳，效率不高的，帮你重新写了一下，自己测试看看吧，目前的代码拆分结果可以完全保留元工 ...

非常感谢老师了，之前一直用那个代码用习惯了，就没有想到去进一步的优化代码。

wang-way

星梦月缘 发表于 2021-4-15 20:06
谢谢老师，请问下为什么用Sheet1.Range("a1:h" & irow).Copy Sheets(j).Range("a1")  用这个代码就会报错 ...

我的经验不一定对，但是我确实遇见过。就是有的版本usedrange就会引用所有包括折叠部分的数据，有的就只是引用了未折叠的部分，不是很稳定。

3190496160

wang-way 发表于 2021-4-15 20:34
我的经验不一定对，但是我确实遇见过。就是有的版本usedrange就会引用所有包括折叠部分的数据，有的就只 ...

usedrange  会把所有有边框甚至是格式的区域都包含在内了

星梦月缘

3190496160 发表于 2021-4-15 20:51
usedrange  会把所有有边框甚至是格式的区域都包含在内了

好的  谢谢老师