[已解决]根据数据内容批量生成新工作簿

风林火山

如图

as0810114

风林火山 发表于 2014-2-25 22:51
如图

真不是我要的结果，我电脑生成的位置不一样。
PS   代码有一个BUG，数据不一定是3列

风林火山

as0810114 发表于 2014-2-25 22:55
真不是我要的结果，我电脑生成的位置不一样。
PS   代码有一个BUG，数据不一定是3列

那你继续写你需要的代码吧

风林火山

as0810114 发表于 2014-2-25 22:55
真不是我要的结果，我电脑生成的位置不一样。
PS   代码有一个BUG，数据不一定是3列

不是三列，用index吧，一下一串，不管你几列

冥王

本机耗时5秒

xdragon

1. Sub splitdata()
   
2.   Dim arr(), i&, j%, re(), cnt&
   
3.   With ThisWorkbook.Sheets("明细")
   
4.      i = .Cells(Rows.Count, 1).End(xlUp).Row
   
5.      j = .Cells(1, Columns.Count).End(xlToLeft).Column
   
6.      arr = .Range(.Cells(1, 1), .Cells(i, j)).Value
   
7.   End With
   
8.   
   
9.   ReDim re(1 To 10000, 1 To UBound(arr, 2))
   
10.   
    
11.   Application.ScreenUpdating = False
    
12.   Application.DisplayAlerts = False
    
13.   For i = 2 To UBound(arr)
    
14.     If arr(i, 1) = 1 Then
    
15.        Do
    
16.           cnt = cnt + 1
    
17.           For j = 1 To UBound(arr, 2)
    
18.             re(cnt, j) = arr(i, j)
    
19.           Next
    
20.           i = i + 1
    
21.           If i > UBound(arr) Then Exit Do
    
22.        Loop Until arr(i, 1) = 1
    
23.        Workbooks.Add (1)
    
24.        Range("A1").Resize(cnt, j - 1) = re
    
25.        ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & re(1, 2), 51
    
26.        ActiveWorkbook.Close
    
27.        cnt = 0: i = i - 1
    
28.     End If
    
29.   Next
    
30.   Application.DisplayAlerts = True
    
31.   Application.ScreenUpdating = True
    
32. End Sub

复制代码

我也参与下，哈哈

xdragon

1. Sub splitdata()
   
2.   Dim arr(), re(), columnheaders(), tmp(1)
   
3.   Dim i&, j%, k&, cnt&, yyb%
   
4.   Dim d As Object
   
5.   With ThisWorkbook.Sheets("明细")
   
6.      i = .Cells(Rows.Count, 1).End(xlUp).Row
   
7.      j = .Cells(1, Columns.Count).End(xlToLeft).Column
   
8.      arr = .Range(.Cells(1, 1), .Cells(i, j)).Value
   
9.      columnheaders = .Range(.Cells(1, 1), .Cells(1, j)).Value
   
10.      yyb = .Range("1:1").Find("营业部", , , xlWhole).Column
    
11.   End With
    
12.   
    
13.   Set d = CreateObject("scripting.dictionary")
    
14.   For i = 2 To UBound(arr)
    
15.      d(arr(i, yyb)) = d(arr(i, yyb)) & "|" & i
    
16.   Next
    
17.   Application.ScreenUpdating = False
    
18.   Application.DisplayAlerts = False
    
19.   tmp(1) = d.items
    
20.   Set d = Nothing
    
21.   For k = 0 To UBound(tmp(1))
    
22.     tmp(0) = Split(tmp(1)(k), "|")
    
23.     ReDim re(1 To UBound(tmp(0)), 1 To UBound(arr, 2) + 1)
    
24.     For i = 1 To UBound(tmp(0))
    
25.       For j = 1 To UBound(arr, 2)
    
26.         re(i, 1) = i
    
27.         re(i, j + 1) = arr(tmp(0)(i), j)
    
28.       Next
    
29.     Next
    
30.     Workbooks.Add (1)
    
31.     Range("A1") = "序号"
    
32.     Range("B1").Resize(1, UBound(arr, 2)) = columnheaders
    
33.     Range("A2").Resize(UBound(re), UBound(re, 2)) = re
    
34.     ActiveWorkbook.SaveAs ThisWorkbook.Path & "" & re(1, yyb + 1), 51
    
35.     ActiveWorkbook.Close
    
36.   Next
    
37.   Application.DisplayAlerts = True
    
38.   Application.ScreenUpdating = True
    
39. End Sub
    

复制代码

加个根据营业部数据做的乱序分类拆分工作簿的代码，看看行不行。