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

bajifeng

》》》》》》》》》》》》》

xiaohuaxiong

bajifeng 发表于 2016-1-14 13:27

非常感谢啊，如果代码有不懂的，请不吝赐教！！

bajifeng

恩，好的，不客气。
如有问题可以跟帖回复。

JJMY

这样的问题也能解决，神了！

xiaohuaxiong

bajifeng 发表于 2016-1-14 13:58
恩，好的，不客气。
如有问题可以跟帖回复。

你好，我刚才仔细注释了下你的代码，代码没有问题，还有一个小要求，能否在每个分表里面加上对应的LOGO图片呢，谢谢


'===========================================
Sub SplitIntoWorkbookByLines()
    Dim r(1 To 100, 1 To 2)
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set wbo = ActiveWorkbook
    s = Array("-------", "INVOICE #") '常量数组
    pth = ThisWorkbook.Path & "\"     '该文件路径
    For j = 0 To UBound(s)
        n = 0
        '-------用find 方法  循环找到虚线和invoice#的行号赋给二维数组r-------------------------------------------
        Set c = Cells.Find(what:=s(j), LookIn:=xlValues, lookat:=xlPart)
        If Not c Is Nothing Then
            addr = c.Address
            Do
                n = n + 1  '计数
                r(n, j + 1) = c.Row
                Set c = Cells.FindNext(c)
            Loop While addr <> c.Address
        End If
        '-----------------------------------------------------------
    Next
    cn = 38 '报表列数
    ReDim cw(1 To cn) '定义一维数组cw装各个列宽
    For i = 1 To cn
        cw(i) = Columns(i).ColumnWidth
    Next
   
    For i = 1 To n
        fnm = wbo.Sheets(1).Cells(r(i, 2), "w") & ".xlsx" 'Cells(r(i, 2), "w")对应invoice#，命名文件，赋给变量fnm
        If i = 1 Then
            sr = 1
        Else
            sr = r(i - 1, 1) + 1  '上一个虚线的行号+1 作为开始行号
        End If
        er = r(i, 1)       '结束行号，如果不要虚线设置为 r(i, 1) - 1
        wbo.Sheets(1).Range(Cells(sr, "a"), Cells(er, "al")).Copy '复制开始行到结束行的区域
        Set wbn = Workbooks.Add '添加工作簿，为活动工作簿
        ActiveSheet.[a1].PasteSpecial '粘贴到该工作簿
   
        For k = 1 To cn
            Columns(k).ColumnWidth = cw(k) '设置对应的列宽
        Next
        ActiveWindow.DisplayGridlines = False '网线不显示
        wbn.SaveAs pth & fnm '另存到 本工作簿的路径，命名为fnm
        wbn.Close False ' 关掉活动工作簿，不保存
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

bajifeng

传一下你的Logo原始图片吧。

xiaohuaxiong

bajifeng 发表于 2016-1-14 16:20
传一下你的Logo原始图片吧。

请查看附件，感谢

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.     ba
    
43.     ActiveWindow.DisplayGridlines = False
    
44.     wbn.SaveAs pth & fnm
    
45.     wbn.Close False
    
46. Next
    
47. End Sub
    
48. Private Sub ba() 'bajifeng
    
49. pth = ThisWorkbook.Path & ""
    
50. With ActiveSheet
    
51.     .Pictures.Insert pth & "logo.jpg"
    
52.     .Pictures.Left = Range("ad2").Left
    
53.     .Pictures.Top = Range("ad2").Top
    
54. End With
    
55. End Sub

复制代码

bajifeng

已经按照您的要求插入图片 并定位

xiaohuaxiong

bajifeng 发表于 2016-1-14 16:51
已经按照您的要求插入图片 并定位

感谢热心帮助啊！！！