多表按部门自动拆分为多工作簿问题

ykcbf1100

述求：当前工作簿目录有三张表（有可能增加），每张表中都有部门这个字段，要求按部门自动拆分为有三张表的以部门名为名的多工作簿。

单表按条件拆分为多工作簿，这个操作常见，但多表按条件拆分为多表工作簿，这个操作少见。

求高手出手相助。叩谢！

3190496160

这个工具应该是可以满足你的需求的，自己看看

jack5d

不明白你想怎樣, 你把分拆後的結果弄出來看看

ykcbf1100

jack5d 发表于 2021-6-9 13:55
不明白你想怎樣, 你把分拆後的結果弄出來看看

就是按原工作簿的工作表结构，把单一部门的数据拆分出来，自动拆分所有部门的数据。

ykcbf1100

3190496160 发表于 2021-6-9 13:49
这个工具应该是可以满足你的需求的，自己看看

我先看看，好象有我需要的。

opel-wong

代码如下，供参考：

opel-wong

代码如下，供参考：

1. Sub 条件拆分()
   
2.     Dim T1 As Date: T1 = Timer
   
3.     Dim arr, i As Long, bm As String, mFile As String, mPath As String
   
4.     Dim Rng As Range, sht As Worksheet, Key
   
5.     Dim d As Object: Set d = CreateObject("Scripting.Dictionary")
   
6.     For Each sht In Worksheets
   
7.         arr = sht.UsedRange.Value
   
8.         For i = 4 To UBound(arr)
   
9.             bm = arr(i, 5)
   
10.             If Len(bm) > 0 And InStr(bm, "部门") = 0 And Not d.Exists(bm) Then d(bm) = Empty
    
11.         Next
    
12.     Next
    
13.     Application.ScreenUpdating = False
    
14.     mPath = ThisWorkbook.Path & "\生成报表\"   ' 报表生成路径，可自行修改
    
15.     If Dir(mPath, vbDirectory) = "" Then MkDir mPath  ' 若文件夹不存在，则建立
    
16.     For Each Key In d.keys
    
17.         Worksheets.Copy
    
18.         For Each sht In Worksheets
    
19.             With sht
    
20.                 arr = .UsedRange.Value
    
21.                 For i = 4 To UBound(arr)
    
22.                     bm = arr(i, 5)
    
23.                     If Len(bm) > 0 And InStr(bm, "部门") = 0 And bm <> Key Then
    
24.                         If Rng Is Nothing Then Set Rng = .Rows(i) Else Set Rng = Application.Union(Rng, .Rows(i))
    
25.                     End If
    
26.                 Next
    
27.             End With
    
28.             If Not Rng Is Nothing Then Rng.Delete: Set Rng = Nothing
    
29.         Next
    
30.         mFile = mPath & Key & ".xlsx"
    
31.         If Dir(mFile, vbHidden + vbNormal) <> "" Then Kill mFile    ' 若同名文件存在，则删除
    
32.         ActiveWorkbook.SaveAs mFile, xlOpenXMLWorkbook  ' 另存
    
33.         ActiveWorkbook.Close    ' 关闭
    
34.     Next
    
35.     Application.ScreenUpdating = True
    
36.     MsgBox "表格已按部门拆分完成，用时约：" & Format(Timer - T1, "0.0" & " 秒！"), 64 + 0, "温馨提醒"
    
37. End Sub

复制代码

ykcbf1100

opel-wong 发表于 2021-6-9 14:14
代码如下，供参考：

试了一下，基本能够满足要求。谢谢。

opel-wong

ykcbf1100 发表于 2021-6-9 15:13
试了一下，基本能够满足要求。谢谢。

你要求可以的哈，还基本满足要求！
牛逼！

ykcbf1100

opel-wong 发表于 2021-6-9 15:34
你要求可以的哈，还基本满足要求！
牛逼！

可能我没说清楚，我其实是想把拆分后的工作簿放在当前目录下的。但根据你的代码运行后发现拆分后的工作簿放在上一级的目录下了，不知道什么原因，我也没仔细去查。我根据你的代码修改了一下，现在是能够满足我自己的要求了。谢谢你了。不过说真的，我其实并没有完全理解你的代码。以下是我稍加修改后的代码：
Sub 多表按部门拆分()
    Dim Start As Double, Finish As Double   '运行时间
    Start = Timer
    Dim arr, i As Long, bm$, mFile$
    Dim Rng As Range, sht As Worksheet, Key
    Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    For Each sht In Worksheets
        If sht.Name <> "拆分台" Then
            arr = sht.UsedRange.Value
            For i = 4 To UBound(arr)
                bm = arr(i, 5)
                If Len(bm) > O And InStr(bm, "部门") = 0 And Not d.Exists(bm) Then
                    d(bm) = Empty
                End If
            Next
        End If
    Next
    Application.ScreenUpdating = False
    For Each Key In d.keys
        If Key <> 0 Then                       '//排除部门为0的部门
            Worksheets.Copy
            For Each sht In Worksheets
                If sht.Name <> "拆分台" Then
                    With sht
                        arr = .UsedRange.Value
                        For i = 4 To UBound(arr)
                            bm = arr(i, 5)
                            If Len(bm) > O And InStr(bm, "部门") = 0 And bm <> Key Then
                                If Rng Is Nothing Then
                                    Set Rng = .Rows(i)
                                Else
                                    Set Rng = Application.Union(Rng, .Rows(i))
                                End If
                            End If
                        Next
                    End With
                    If Not Rng Is Nothing Then
                        Rng.Delete
                    End If
                    Set Rng = Nothing
                End If
            Next
            mFile = Key & ".xlsx"
            If Dir(mFile, vbHidden + vbNormal) <> "" Then
                Kill mFile                                    '//若同名文件存在,则删除
            End If
            ActiveWorkbook.Sheets("拆分台").Select
            Application.DisplayAlerts = False                '//关闭系统提示
            ActiveWindow.SelectedSheets.Delete               '//删除多余表
            Application.DisplayAlerts = True                 '//恢复系统提示
            ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & mFile, FileFormat:=51    '原格式另存为一个新工作簿
            ActiveWorkbook.Close 关闭
        End If
    Next
    Application.ScreenUpdating = True
    Finish = Timer
    MsgBox "数据拆分完毕，共用时：" & Finish - Start & "秒"
End Sub