根据分割线把文件拆分成不同的工作簿

xiaohuaxiong

根据分割线把文件拆分成不同的工作簿，以INVOICE #:右边的数值命名工作簿文件，格式要完全保留，谢谢。

bajifeng

再次确认一下
是拆成工作薄而不是工作表？

xiaohuaxiong

bajifeng 发表于 2016-1-14 11:32
再次确认一下
是拆成工作薄而不是工作表？

你好，是拆成工作簿。谢谢

bajifeng

xiaohuaxiong 发表于 2016-1-14 11:33
你好，是拆成工作簿。谢谢

恩，好的
每个工作薄需要不需要包含虚线一行

xiaohuaxiong

bajifeng 发表于 2016-1-14 12:32
恩，好的
每个工作薄需要不需要包含虚线一行

可以啊，把虚线留在最后面就可以啦，感谢

bajifeng

1. Sub 根据分割线拆分成不同工作薄() 'bajifeng
   
2. Dim r(1 To 100, 1 To 2)
   
3. Set wbo = ActiveWorkbook
   
4. s = Array("-------", "INVOICE #")
   
5. pth = ThisWorkbook.Path & ""
   
6. For j = 0 To UBound(s)
   
7.     n = 0
   
8.     Set c = Cells.Find(what:=s(j), LookIn:=xlValues, lookat:=xlPart)
   
9.     If Not c Is Nothing Then
   
10.         addr = c.Address
    
11.         Do
    
12.             n = n + 1
    
13.             r(n, j + 1) = c.Row
    
14.             Set c = Cells.FindNext(c)
    
15.         Loop While addr <> c.Address
    
16.     End If
    
17. Next
    
18. For i = 1 To n
    
19.     fnm = wbo.Sheets(1).Cells(r(i, 2), "w") & ".xlsx"
    
20.     If i = 1 Then
    
21.         sr = 1
    
22.     Else
    
23.         sr = r(i - 1, 1)
    
24.     End If
    
25.     er = r(i, 1) - 1
    
26.     wbo.Sheets(1).Range(Cells(sr, "a"), Cells(er, "al")).Copy
    
27.     Set wbn = Workbooks.Add
    
28.     ActiveSheet.[a1].PasteSpecial
    
29.     wbn.SaveAs pth & fnm
    
30.     wbn.Close False
    
31. Next
    
32. End Sub

复制代码

bajifeng

>>>>>>>>>>>>>>>>>>>>

xiaohuaxiong

bajifeng 发表于 2016-1-14 12:55
>>>>>>>>>>>>>>>>>>>>

你好，谢谢啊，不过有个条件，拆分后的表 的格式要和源表完全一致，麻烦再看看

bajifeng

xiaohuaxiong 发表于 2016-1-14 13:11
你好，谢谢啊，不过有个条件，拆分后的表 的格式要和源表完全一致，麻烦再看看

恩，好的，那就再改改吧
保证一模一样。

bajifeng

1. Sub 根据分割线拆分成不同工作薄()    'bajifeng
   
2. 'http://club.excelhome.net/thread-1254084-1-1.html
   
3. Dim r(1 To 100, 1 To 2)
   
4. Set wbo = ActiveWorkbook
   
5. s = Array("-------", "INVOICE #")
   
6. pth = ThisWorkbook.Path & ""
   
7. 
   
8. For j = 0 To UBound(s)
   
9.     n = 0
   
10.     Set c = Cells.Find(what:=s(j), LookIn:=xlValues, lookat:=xlPart)
    
11.     If Not c Is Nothing Then
    
12.         addr = c.Address
    
13.         Do
    
14.             n = n + 1
    
15.             r(n, j + 1) = c.Row
    
16.             Set c = Cells.FindNext(c)
    
17.         Loop While addr <> c.Address
    
18.     End If
    
19. Next
    
20. 
    
21. cn = 38
    
22. ReDim cw(1 To cn)
    
23. For i = 1 To cn
    
24.     cw(i) = Columns(i).ColumnWidth
    
25. Next
    
26. 
    
27. For i = 1 To n
    
28.     fnm = wbo.Sheets(1).Cells(r(i, 2), "w") & ".xlsx"
    
29.     If i = 1 Then
    
30.         sr = 1
    
31.     Else
    
32.         sr = r(i - 1, 1) + 1
    
33.     End If
    
34.     er = r(i, 1)       '如果不要虚线设置为 r(i, 1) - 1
    
35.     wbo.Sheets(1).Range(Cells(sr, "a"), Cells(er, "al")).Copy
    
36.     Set wbn = Workbooks.Add
    
37.     ActiveSheet.[a1].PasteSpecial
    
38. 
    
39.     For k = 1 To cn
    
40.         Columns(k).ColumnWidth = cw(k)
    
41.     Next
    
42.     ActiveWindow.DisplayGridlines = False
    
43.     wbn.SaveAs pth & fnm
    
44.     wbn.Close False
    
45. Next
    
46. End Sub

复制代码