根据总表的负责区域拆分为不同的工作簿

vicky427000

拆分表格.rar (13.45 KB, 下载次数: 5)

2024-3-12 14:31 上传

点击文件名下载附件
拆分

附件中的每个人有一个表格，但是现在根据目录表格的负责区域，要拆分为新的工作簿，方便我们发给区域负责人，要求拆分为不同工作簿，A工作簿，B工作簿，C工作簿，大家帮忙看看，用什么VBA代码，谢谢。

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.12
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set ws = ThisWorkbook
   
6.     Set sh = ws.Sheets("目录")
   
7.     arr = sh.UsedRange
   
8.     p = ThisWorkbook.Path & ""
   
9.     For i = 2 To UBound(arr)
   
10.         s = arr(i, 3)
    
11.         If Not d.exists(s) Then
    
12.             d(s) = arr(i, 2)
    
13.         Else
    
14.             d(s) = d(s) & " " & arr(i, 2)
    
15.         End If
    
16.     Next
    
17.     For Each k In d.keys
    
18.         fn = Split(d(k))
    
19.         ws.Sheets(fn).Copy
    
20.         Set wb = ActiveWorkbook
    
21.         wb.SaveAs Filename:=p & k
    
22.         wb.Close
    
23.     Next
    
24.     Set d = Nothing
    
25.     Application.ScreenUpdating = True
    
26.     MsgBox "OK！"
    
27. End Sub
    
28. 
    

复制代码

fzxba

1. Sub test0()
   
2.   Dim Conn As Object, rs As Object, p As String, f As String, s As String
   
3.   p = ThisWorkbook.Path & "\分簿"
   
4.   If Dir(p, vbDirectory) = "" Then MkDir p
   
5.   Set Conn = CreateObject("ADODB.Connection")
   
6.   Set rs = CreateObject("ADODB.Recordset")
   
7.   Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & ThisWorkbook.FullName
   
8.   s = "SELECT DISTINCT 负责区域 FROM [" & ActiveSheet.Name & "$] WHERE LEN(负责区域)"
   
9.   rs.Open s, Conn, 1, 3
   
10.   While Not rs.EOF
    
11.     s = rs.Fields(0).Value
    
12.     f = p & Application.PathSeparator & s & ".xlsx"
    
13.     If Dir(f) <> "" Then Kill f
    
14.     Conn.Execute "SELECT * INTO [" & f & "].[" & s & "] FROM [" & ActiveSheet.Name & "$] WHERE 负责区域='" & s & "'"
    
15.     rs.MoveNext
    
16.   Wend
    
17.   rs.Close
    
18.   Set rs = Nothing
    
19.   Conn.Close
    
20.   Set Conn = Nothing
    
21.   Beep
    
22. End Sub

复制代码

fzxba

拆分表格.rar (33.98 KB, 下载次数: 10)

2024-3-12 20:52 上传

点击文件名下载附件

vicky427000

谢谢哈，非常感谢

vicky427000

ykcbf1100 发表于 2024-3-12 19:11
参与一下。。。

fzxba 我运行她得回答，不会有问题，为啥你的总是提示出错ws.Sheets(fn).Copy，我检查了我的表格名称是一致得，我就用fzxba的代码，她的代码不会出问题