救命啊！如何将1个excel根据某列拆分为多个excel

g12048

opiona 发表于 2011-12-28 18:04

如果过于麻烦的话，就保留1-5行的公式这点可以吗

g12048

别沉了，急用的呀

g12048

无人能解吗？哭了

350389954

太个性化的需求建议不要用EXCEL来完成，几十万的数据量建议用数据库来完成

yangang730105

opiona 发表于 2011-12-28 18:04

请帮忙把他做在一个工作簿里可以吗？谢谢了！

ykcbf1100

纯练手。

2011年的求助帖，最后也没解决，好吧，今天我来解决一下吧。
这里主要有个隐藏表要同步拷贝到新工作簿的问题。

ykcbf1100

代码已经调试通过。。。

1. Sub ykcbf()   '//2024.2.3
   
2.     Dim wb, arr, sh
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Dim tm: tm = Timer
   
6.     Set fso = CreateObject("Scripting.FileSystemObject")
   
7.     Set d = CreateObject("Scripting.Dictionary")
   
8.     p = ThisWorkbook.Path & ""
   
9.     p1 = p & "MY DOCUMENT"
   
10.     If Not fso.FolderExists(p1) Then fso.CreateFolder p1
    
11.     Set ws = ThisWorkbook
    
12.     Set sh = ws.Sheets("Sheet4")
    
13.     With ws
    
14.         ws.Sheets("Sheet5").Visible = -1
    
15.         arr = sh.UsedRange
    
16.     End With
    
17.     For i = 8 To UBound(arr)
    
18.         s = arr(i, 1)
    
19.         If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
20.         d(s)(i) = i
    
21.     Next
    
22.     For Each k In d.keys
    
23.         ws.Sheets(Array("Sheet4", "Sheet5")).Copy
    
24.         Set wb = ActiveWorkbook
    
25.         wb.Sheets("Sheet5").Visible = 0
    
26.         m = 0
    
27.         ReDim brr(1 To d(k).Count, 1 To UBound(arr, 2))
    
28.         With wb.Sheets(sh.Name)
    
29.             .Name = k
    
30.             .DrawingObjects.Delete
    
31.             .UsedRange.Offset(7 + d(k).Count).Clear
    
32.             For Each kk In d(k).keys
    
33.                 fn = k
    
34.                 m = m + 1
    
35.                 For j = 1 To UBound(arr, 2)
    
36.                     brr(m, j) = arr(kk, j)
    
37.                 Next
    
38.             Next
    
39.             .Range("a:a,g:g").NumberFormatLocal = "@"
    
40.             .[a8].Resize(m, UBound(brr, 2)) = brr
    
41.         End With
    
42.         wb.SaveAs p1 & fn
    
43.         wb.Close 1
    
44.     Next
    
45.     ws.Sheets("Sheet5").Visible = 0
    
46.     Set d = Nothing
    
47.     Application.ScreenUpdating = True
    
48.     MsgBox "拆分完毕，共用时：" & Format(Timer - tm) & "秒！"
    
49. End Sub
    

复制代码