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

opel-wong

ykcbf1100 发表于 2021-6-9 16:19
可能我没说清楚，我其实是想把拆分后的工作簿放在当前目录下的。但根据你的代码运行后发现拆分后的工作簿 ...

这句不对，mFile = Key & ".xlsx"
应该修改为：
mFile = ThisWorkbook.Path & "\" & Key & ".xlsx"

ykcbf1100

opel-wong 发表于 2021-6-10 08:20
这句不对，mFile = Key & ".xlsx"
应该修改为：
mFile = ThisWorkbook.Path & "\" & Key & ".xlsx"

是这样的，我是单纯生成部门为名的工作簿的，不需要加上原工作簿文件名的。象这样：车商二部.xlsx。因为我的.SaveAs Filename:=ThisWorkbook.Path & "\" & mFile, FileFormat:=51 是这样写的，所以，mFile = Key & ".xlsx"就够了。效果一样的，只不过ThisWorkbook.Path & "\" &你写在前面，我写在后面。

opel-wong

ykcbf1100 发表于 2021-6-10 08:38
是这样的，我是单纯生成部门为名的工作簿的，不需要加上原工作簿文件名的。象这样：车商二部.xlsx。因为 ...

你好好理解一下这段代码吧，然后你就会知道为什么了，

            mFile = Key & ".xlsx"
            If Dir(mFile, vbHidden + vbNormal) <> "" Then
                Kill mFile                                    '//若同名文件存在,则删除
            End If

ykcbf1100

opel-wong 发表于 2021-6-10 08:54
你好好理解一下这段代码吧，然后你就会知道为什么了，

            mFile = Key & ".xlsx"

哦，对对对，是我没看清楚。是我错了。

ericxzhou

1. Sub test()
   
2.     Dim i%, d, arr, arr1, wks As Worksheet, wkb As Workbook
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     arr = Sheet1.[a1].CurrentRegion
   
6.     For i = 4 To UBound(arr)
   
7.         d(arr(i, 5)) = ""
   
8.     Next
   
9.     arr1 = d.keys
   
10.     For i = 0 To UBound(arr1)
    
11.         Set wkb = Workbooks.Add
    
12.         Set wks = wkb.Sheets(1): wks.Name = ThisWorkbook.Sheets(1).Name
    
13.         With ThisWorkbook.Sheets(1)
    
14.             .AutoFilterMode = False
    
15.             .Rows("3:3").AutoFilter field:=5, Criteria1:=arr1(i)
    
16.             .[a1].CurrentRegion.Copy wkb.Sheets(1).[a1]
    
17.         End With
    
18.         Set wks = wkb.Sheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
    
19.         wks.Name = ThisWorkbook.Sheets(2).Name
    
20.         With ThisWorkbook.Sheets(2)
    
21.             .AutoFilterMode = False
    
22.             .Rows("2:2").AutoFilter field:=5, Criteria1:=arr1(i)
    
23.             .[a1].CurrentRegion.Copy wkb.Sheets(2).[a1]
    
24.         End With
    
25.         Set wks = wkb.Sheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
    
26.         wks.Name = ThisWorkbook.Sheets(3).Name
    
27.         With ThisWorkbook.Sheets(3)
    
28.             .AutoFilterMode = False
    
29.             .Rows("4:4").AutoFilter field:=5, Criteria1:=arr1(i)
    
30.             .[a4].CurrentRegion.Copy wkb.Sheets(3).[a4]
    
31.         End With
    
32.         wkb.SaveAs ThisWorkbook.Path & "" & arr1(i) & ".xlsx"
    
33.         wkb.Close False
    
34.     Next
    
35.     Application.ScreenUpdating = True
    
36. End Sub

复制代码

ExcelHomeFM

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

这是什么编辑器？

ykcbf1100

ericxzhou 发表于 2021-6-10 12:30

试了一下，能用。不过这一句通不过，wks.Name = ThisWorkbook.Sheets(1).Name，改成wks.Name = ThisWorkbook.Sheets(“考核总表”).Name就通过了。

ykcbf1100

ericxzhou 发表于 2021-6-10 12:30

1. Sub 多表拆分()               '//可以使用，拆分速度快，2021.6.11
   
2.     Dim i%, d, mFile$, arr, arr1, wks As Worksheet, wkb As Workbook
   
3.     Dim Start As Double, Finish As Double   '运行时间
   
4.     Start = Timer
   
5.     Application.ScreenUpdating = False
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     Dim wb As Workbook
   
8.     Set wb = ThisWorkbook
   
9.     Dim sht1 As Worksheet, sht2 As Worksheet, sht3 As Worksheet
   
10.     Set sht1 = Sheet1              '//考核表
    
11.     Set sht2 = Sheet10             '//个人已发
    
12.     Set sht3 = Sheet2              '//个人数据
    
13.     arr = sht1.[a1].CurrentRegion
    
14.     For i = 4 To UBound(arr)
    
15.         d(arr(i, 5)) = ""          '//这里的5是代表部门所在列
    
16.     Next
    
17.     arr1 = d.keys
    
18.     For i = 0 To UBound(arr1)
    
19.         If arr1(i) <> 0 Then                  '//把值为0的部门排除在外
    
20.             Set wkb = Workbooks.Add
    
21.             Set wks = wkb.Sheets(1): wks.Name = sht1.Name
    
22.             With sht1
    
23.                 .AutoFilterMode = False
    
24.                 .Rows("2:2").AutoFilter field:=5, Criteria1:=arr1(i)
    
25.                 .[a1].CurrentRegion.Offset(1, 0).Copy wkb.Sheets(1).[a1]
    
26.                 .ShowAllData
    
27.             End With
    
28.             Set wks = wkb.Sheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
    
29.             wks.Name = sht2.Name
    
30.             With sht2
    
31.                 .AutoFilterMode = False
    
32.                 .Rows("2:2").AutoFilter field:=5, Criteria1:=arr1(i)
    
33.                 .[a1].CurrentRegion.Offset(1, 0).Copy wkb.Sheets(2).[a1]
    
34.                 .ShowAllData
    
35.             End With
    
36.             Set wks = wkb.Sheets.Add(after:=wkb.Sheets(wkb.Sheets.Count))
    
37.             wks.Name = sht3.Name
    
38.             With sht3
    
39.                 .AutoFilterMode = False
    
40.                 .Rows("4:4").AutoFilter field:=5, Criteria1:=arr1(i)
    
41.                 .[a4].CurrentRegion.Copy wkb.Sheets(3).[a1]
    
42.                 .ShowAllData
    
43.             End With
    
44.             mFile = wb.Path & "" & arr1(i) & ".xlsx"
    
45.             If Dir(mFile, vbHidden + vbNormal) <> "" Then
    
46.                 Kill mFile                                    '//若同名文件存在,则删除
    
47.             End If
    
48.             wkb.SaveAs Filename:=mFile, FileFormat:=51        '//原格式另存为一个新表
    
49.             wkb.Close Savechanges:=False
    
50.         End If
    
51.     Next
    
52.     Application.ScreenUpdating = True
    
53.     Finish = Timer
    
54.     MsgBox "数据拆分完毕，共用时：" & Finish - Start & "秒"
    
55. End Sub
    

复制代码

你的代码运行速度挺快的，在我的电脑上大约14秒拆分完毕。别的代码需要2分多钟才拆分好。
我在你的代码的基础上完善了一下，现在运行正常。
代码如下：

ykcbf1100

三年前的求助，我自己来完成一下。

5秒完成，是我的电脑配置比以前高了吧，运行时间少了。

ykcbf1100

多表拆分为多工作簿，通用性比较强

1. Sub 多表按部门拆分()   '//2024.6.13
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Dim t: t = Timer
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set ws = ThisWorkbook
   
7.     p = ThisWorkbook.Path & ""
   
8.     For Each sht In ws.Sheets
   
9.         With sht
   
10.             c = .UsedRange.Columns.Count
    
11.             r = .UsedRange.Rows.Count
    
12.             bt = .UsedRange.Find("序号").Row
    
13.             col = Application.WorksheetFunction.Match("部门", .Rows(bt), 0)
    
14.             arr = .[a1].Resize(r, c)
    
15.         End With
    
16.         For i = bt + 1 To UBound(arr)
    
17.             s = Trim(arr(i, col))
    
18.             If s <> "" Then d(s) = ""
    
19.         Next i
    
20.     Next sht
    
21.     For Each k In d.keys
    
22.         ws.Sheets.Copy
    
23.         Set wb = ActiveWorkbook
    
24.         For Each sht In wb.Sheets
    
25.             m = 0
    
26.             Set rng = Nothing
    
27.             With sht
    
28.                 arr = .UsedRange
    
29.                 bt = .UsedRange.Find("序号").Row
    
30.                 col = Application.WorksheetFunction.Match("部门", .Rows(bt), 0)
    
31.                 .DrawingObjects.Delete
    
32.                 For i = bt + 1 To UBound(arr)
    
33.                     If Trim(arr(i, col)) = k Then
    
34.                         m = m + 1
    
35.                     Else
    
36.                         If rng Is Nothing Then
    
37.                             Set rng = .Rows(i)
    
38.                         Else
    
39.                             Set rng = Union(rng, .Rows(i))
    
40.                         End If
    
41.                     End If
    
42.                 Next i
    
43.                 If Not rng Is Nothing Then rng.Delete
    
44.             End With
    
45.         Next
    
46.         wb.SaveAs p & k
    
47.         wb.Close
    
48.     Next k
    
49.     Application.ScreenUpdating = True
    
50.     Application.DisplayAlerts = True
    
51.     MsgBox "拆分完毕，共用时： " & Format(Timer - t, "0.000秒"), , "提示"
    
52. End Sub
    
53. 
    

复制代码