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

as0810114

话不多说，详见附件说明。

最佳答案

月排行榜 / 总排行榜

xdragon

2014-2-26 12:32

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

复制代码

我也参与下，哈哈

跳转到最佳答案楼层

冥王

1. Sub AddBK()
   
2. Application.ScreenUpdating = False
   
3. Application.DisplayAlerts = False
   
4.     Dim Newbook As Workbook
   
5.     Dim ShName As Variant
   
6.     Dim Arr(1 To 14) As Variant
   
7.     Dim i As Integer
   
8.     Dim myNewWorkbook As Integer
   
9. For i = 1 To 14
   
10. Arr(i) = ThisWorkbook.Sheets("明细").Cells(i + 12, 6)
    
11. Next
    
12. 
    
13. For i = LBound(Arr) To UBound(Arr)
    
14.     Set Newbook = Workbooks.Add
    
15.      With Newbook.Sheets(1)
    
16.          ThisWorkbook.Sheets("明细").Rows("1:1").Copy .Cells(1, 1)
    
17.        Set c = ThisWorkbook.Sheets("明细").Range("B:B").Find(Arr(i))
    
18.             If Not c Is Nothing Then
    
19.                 firstAddress = c.Address
    
20.                 Do
    
21.                  m = c.Row
    
22.                  n = .[A65536].End(xlUp).Row
    
23.                  ThisWorkbook.Sheets("明细").Rows(m).Copy .Cells(n + 1, 1)
    
24.                   Set c = ThisWorkbook.Sheets("明细").Range("B:B").FindNext(c)
    
25.          
    
26.                 Loop While Not c Is Nothing And c.Address <> firstAddress
    
27.             Else
    
28.             MsgBox ("无数据")
    
29.             End If
    
30.          n = .[A65536].End(xlUp).Row
    
31.          Newbook.SaveAs Filename:=ThisWorkbook.Path & "" & Arr(i)
    
32.          Newbook.Close Savechanges:=True
    
33.         Set Newbook = Nothing
    
34.       End With
    
35. Next
    
36. 
    
37. Application.DisplayAlerts = True
    
38. Application.ScreenUpdating = True
    
39. End Sub

复制代码

风林火山

1. Sub 汇总()
   
2.     Dim arr, brr(), k%, i%, m%, n%, tmp
   
3.     Dim d As Object
   
4.     arr = Range("a1").CurrentRegion
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     For k = 2 To UBound(arr)
   
7.         If Not d.exists(arr(k, 2)) Then
   
8.             d(arr(k, 2)) = ""
   
9.         End If
   
10.     Next k
    
11.     Application.ScreenUpdating = False
    
12.     tmp = d.keys
    
13.     For i = 1 - 1 To d.Count - 1
    
14.         For k = 2 To UBound(arr)
    
15.             If arr(k, 2) = tmp(i) Then
    
16.                 n = n + 1
    
17.                 ReDim Preserve brr(1 To 3, 1 To n)
    
18.                 For m = 1 To 3
    
19.                     brr(1, n) = arr(k, 1)
    
20.                     brr(2, n) = arr(k, 2)
    
21.                     brr(3, n) = arr(k, 3)
    
22.                 Next m
    
23.             End If
    
24.         Next k
    
25.         Range("a1:c3").Copy
    
26.         Workbooks.Add
    
27.         Range("a1").PasteSpecial (xlPasteAll)
    
28.         Range("a2").Resize(n, 3) = Application.Transpose(brr)
    
29.         ActiveWorkbook.SaveAs tmp(i) & ".xlsx"
    
30.         ActiveWorkbook.Close 0
    
31.         Erase brr: n = 0
    
32.     Next i
    
33.     Application.ScreenUpdating = True
    
34. End Sub

复制代码

冠军欧洲2010

A董的提问。
绝对要参加哇。

1. Sub A()
   
2.     Application.ScreenUpdating = False
   
3.     Dim ARR, BRR(1 To 100000, 1 To 3)
   
4.     Dim M, N, I, K
   
5.     Dim WO As Workbook
   
6.     Dim SR
   
7.     SR = ThisWorkbook.Path & Application.PathSeparator
   
8.     ARR = Range("A2:C" & Cells(Rows.Count, 3).End(3).Row + 1)
   
9.     BRR(1, 1) = "序号"
   
10.     BRR(1, 2) = "营业部"
    
11.     BRR(1, 3) = "数据"
    
12.     N = 1
    
13.     For M = 1 To UBound(ARR) - 1
    
14.         N = N + 1
    
15.         BRR(N, 1) = ARR(M, 1)
    
16.         BRR(N, 2) = ARR(M, 2)
    
17.         BRR(N, 3) = ARR(M, 3)
    
18.         If ARR(M, 2) <> ARR(M + 1, 2) Then
    
19.             Set WO = Workbooks.Add
    
20.             ActiveSheet.Cells(1, 1).Resize(N, 3) = BRR
    
21.             WO.SaveAs SR & ARR(M, 2) & ".xls"
    
22.             WO.Close
    
23.             N = 1
    
24.             Erase BRR
    
25.             BRR(1, 1) = "序号"
    
26.             BRR(1, 2) = "营业部"
    
27.             BRR(1, 3) = "数据"
    
28.         End If
    
29.     Next
    
30.     Application.ScreenUpdating = True
    
31.     MsgBox "ok"
    
32. End Sub
    

复制代码

冠军欧洲2010

你什么破机子啊。
火星版的吧。
赶紧让他该去那去那吧。

风林火山

风林火山 发表于 2014-2-25 18:25

不是藏起来了，是你说的要和这个文件在一个文件夹，所以就没用thisworkbook.path

as0810114

风林火山 发表于 2014-2-25 22:29
不是藏起来了，是你说的要和这个文件在一个文件夹，所以就没用thisworkbook.path

是同一个文件夹啊，所以肯定要用到path的。

as0810114

冠军欧洲2010 发表于 2014-2-25 22:25
你什么破机子啊。
火星版的吧。
赶紧让他该去那去那吧。

能否优化一下，注意第一列只要数字等于1，就新增工作簿。

风林火山

as0810114 发表于 2014-2-25 22:44
是同一个文件夹啊，所以肯定要用到path的。

同一个文件夹不需要路径的，直接就使用该文件的路径了。

as0810114

风林火山 发表于 2014-2-25 22:46
同一个文件夹不需要路径的，直接就使用该文件的路径了。

生成的文件不在我发的需求文件夹中