[已解决]工作簿拆分成同目录下的多个工作簿

flybeyondsky

按照A列 仓库名称来拆分，保留表头，新生成的文件名就是 仓库名称。 我尝试写了些代码，能力有限，希望能指点我。(用数组来做，不用数据库）

最佳答案

月排行榜 / 总排行榜

独奏

2014-3-6 16:22

请先保存好副本

1. Sub test()
   
2. Dim arr, brr(), r, c, x, y, d, dk
   
3. br = Sheets("sheet1").Range("a1:e1")
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheets("sheet1").Range("a2:e" & [a65536].End(xlUp).Row)
   
6.     For r = LBound(arr) To UBound(arr)
   
7.         If Not d.exists(arr(r, 1)) Then
   
8.             d(arr(r, 1)) = ""
   
9.         End If
   
10.     Next
    
11.     dk = d.keys
    
12.     For x = LBound(dk) To UBound(dk)
    
13.         For r = LBound(arr) To UBound(arr)
    
14.             If arr(r, 1) = dk(x) Then
    
15.                 y = y + 1
    
16.                 ReDim Preserve brr(1 To 5, 1 To y)
    
17.                 For i = 1 To 5
    
18.                     brr(i, y) = arr(r, i)
    
19.                 Next
    
20.             End If
    
21.         Next
    
22.         Set wb = Workbooks.Add
    
23.         With wb
    
24.             .Sheets(1).Range("a1").Resize(, 5) = br
    
25.             .Sheets(1).Range("a2").Resize(y, 5) = Application.Transpose(brr)
    
26.             .SaveAs (ThisWorkbook.Path & "" & brr(1, 2) & ".xlsx")
    
27.             .Close 0
    
28.         End With
    
29.         y = 0
    
30.         Erase brr
    
31.     Next
    
32. set d=nothing
    
33. set arr=nothing
    
34. End Sub
    

复制代码

跳转到最佳答案楼层

ghostjiao

http://www.excelpx.com/thread-297695-1-1.html
这是爱疯版主的

flybeyondsky

ghostjiao 发表于 2014-3-6 15:08
http://www.excelpx.com/thread-297695-1-1.html
这是爱疯版主的

我就想学习下 这种工作簿要怎么拆分啊  不想用工具。

独奏

请先保存好副本

1. Sub test()
   
2. Dim arr, brr(), r, c, x, y, d, dk
   
3. br = Sheets("sheet1").Range("a1:e1")
   
4. Set d = CreateObject("scripting.dictionary")
   
5. arr = Sheets("sheet1").Range("a2:e" & [a65536].End(xlUp).Row)
   
6.     For r = LBound(arr) To UBound(arr)
   
7.         If Not d.exists(arr(r, 1)) Then
   
8.             d(arr(r, 1)) = ""
   
9.         End If
   
10.     Next
    
11.     dk = d.keys
    
12.     For x = LBound(dk) To UBound(dk)
    
13.         For r = LBound(arr) To UBound(arr)
    
14.             If arr(r, 1) = dk(x) Then
    
15.                 y = y + 1
    
16.                 ReDim Preserve brr(1 To 5, 1 To y)
    
17.                 For i = 1 To 5
    
18.                     brr(i, y) = arr(r, i)
    
19.                 Next
    
20.             End If
    
21.         Next
    
22.         Set wb = Workbooks.Add
    
23.         With wb
    
24.             .Sheets(1).Range("a1").Resize(, 5) = br
    
25.             .Sheets(1).Range("a2").Resize(y, 5) = Application.Transpose(brr)
    
26.             .SaveAs (ThisWorkbook.Path & "" & brr(1, 2) & ".xlsx")
    
27.             .Close 0
    
28.         End With
    
29.         y = 0
    
30.         Erase brr
    
31.     Next
    
32. set d=nothing
    
33. set arr=nothing
    
34. End Sub
    

复制代码

flybeyondsky

独奏 发表于 2014-3-6 16:22
请先保存好副本

感谢 通过这个列子 好好的理解了动态数组 再次感谢

問天

学习帮顶