求助大神帮我拆分工资表按每个部门拆分成一个文档，谢谢

cycyaya

    大家好，最近工作上有个难题，想请教一下大家。我手上有一个word工资表，里面有100多个部门的数据。现在想实现按部门导出数据生成单独的word文件。就是每个部门一个word文件，100多个，每个文档都以第一行部门名字命名，例如：“某某部门 在 职 人 员 工 资 发 放 明 细 表.doc"。可以实现吗？请教群里的大神！谢谢了！如能解决，感激不尽。附件是样版，为了方便，只保留了一些举例的数据。

我在论坛里找到一个使用标题分离成一个个文档的方法。按理应该可以实现

http://club.excelhome.net/thread-635894-1-1.html   就是参考的这个方法

确实是可以分离了，但是分享后的数据表格格式却是乱的，而且代码运行到最后会出差，不知道为什么。

有没有大神帮我看看，泪奔！~

以下是我用的代码：

Sub 按标题拆分文档()
Dim myDoc As Document, mytitle As String, a As String, i As Byte
Dim lngStart As Long, lngEnd As Long, myStart As Long, n As Integer
Application.ScreenUpdating = False
Set myDoc = ActiveDocument
myDoc.ActiveWindow.WindowState = wdWindowStateMinimize
a = "\/:*?""<>|"
With myDoc.Content.Find
    .ClearFormatting
    .Font.Name = "宋体"   '各独立小文档标题字体
    .Font.Size = 16 '各独立小文档标题字号，16号即三号字体
    .Format = True
    Do While .Execute
        n = n + 1
        With .Parent
            lngStart = .Start
            lngEnd = .Paragraphs(1).Range.End
            .MoveUntil Chr(13), wdBackward
            If n > 1 Then
                Documents.Add.Content.FormattedText = myDoc.Range(IIf(n = 2, 0, myStart), .Start).FormattedText
                ActiveDocument.PageSetup.Orientation = wdOrientLandscape '横向页面
                ActiveDocument.SaveAs myDoc.Path & "\" & mytitle & ".doc"
                'ActiveDocument.SaveAs Replace(myDoc.FullName, ".doc", "") & "_" & n - 1 & ".doc"
                ActiveDocument.Close
            End If
            mytitle = Trim(myDoc.Range(lngStart, lngEnd - 1).Text)
            For i = 1 To Len(a)
                mytitle = Replace(mytitle, Mid(a, i, 1), "")
            Next
            myStart = .Start
            .SetRange lngEnd, lngEnd
        End With
    Loop
    If n > 1 Then
        Documents.Add.Content.FormattedText = myDoc.Range(myStart, myDoc.Content.End).FormattedText
        ActiveDocument.PageSetup.Orientation = wdOrientLandscape '横向页面
        ActiveDocument.SaveAs myDoc.Path & "\" & mytitle & ".doc"
        'ActiveDocument.SaveAs Replace(myDoc.FullName, ".doc", "") & "_" & n & ".doc"
        ActiveDocument.Close
    End If
End With
Application.ScreenUpdating = True
myDoc.ActiveWindow.WindowState = wdWindowStateNormal
MsgBox IIf(n > 1, "已将活动文档拆分并另存为" & n & "个小文档。", "活动文档不具备指定的拆分条件。")

End Sub





2016年10月工资表（样版）word格式.zip (23.44 KB, 下载次数: 0)

duquancai

可以实现，你的想法完全没问题。

cycyaya

duquancai 发表于 2017-1-15 19:47
可以实现，你的想法完全没问题。

大神，能不能帮我测试一下我的代码哪里出错的。为什么生成的文档表格乱了。没有原来的格式。谢谢了！

duquancai

cycyaya 发表于 2017-1-15 22:08
大神，能不能帮我测试一下我的代码哪里出错的。为什么生成的文档表格乱了。没有原来的格式。谢谢了！

那得具体干活写代码啊！很累的！！！修改代码比写代码还累，话说，这代码针对你的问题并不是最佳方案。

microyip

duquancai 发表于 2017-1-15 22:37
那得具体干活写代码啊！很累的！！！修改代码比写代码还累，话说，这代码针对你的问题并不是最佳方案。

写代码的确容易点，完全按自己思路操作，但修改代码的确很困难，首先要把别人的代码看完，还得理解思路，累死人不填命

duquancai

cycyaya 发表于 2017-1-15 22:08
大神，能不能帮我测试一下我的代码哪里出错的。为什么生成的文档表格乱了。没有原来的格式。谢谢了！

提供思路及模板！如图所示：

QQ214189912

1. Sub 查找配合通配符()
   
2. Dim i As Integer, n As Integer, doxt, Document, dox As Document
   
3. Dim arr, Brr(1 To 100, 1 To 3)
   
4. arr = Array("部门*表", "第[0-9]页,共[0-9]页")
   
5. For i = 0 To UBound(arr)
   
6.   With ThisDocument.Content.Find
   
7.     .Text = arr(i)
   
8.     .MatchWildcards = True
   
9.     n = 0
   
10.     Do While .Execute
    
11.       n = n + 1
    
12.       If i Mod 2 Then
    
13.         Brr(n, 2) = .Parent.End
    
14.       Else
    
15.         Brr(n, 1) = .Parent.Start
    
16.         Brr(n, 3) = .Parent.Text
    
17.       End If
    
18.     Loop
    
19.   End With
    
20. Next
    
21.   For i = 1 To n
    
22.     Set doxt = ThisDocument.Range(Brr(i, 1) - 1, Brr(i, 2))
    
23.     doxt.Select
    
24.     doxt.Copy
    
25.     Set dox = Documents.Add(ThisDocument.FullName)
    
26.     With dox
    
27.       .Content.Delete
    
28.       .Content.Paste
    
29.       .SaveAs ThisDocument.Path & "" & Brr(i, 3) & ".docx"
    
30.       .Close True
    
31.     End With
    
32.   Next i
    
33.   MsgBox "拆分了 " & n & " 文档"
    
34. End Sub

复制代码

cycyaya

5555~~

我太笨了，理解不了这些代码。。

duquancai

cycyaya 发表于 2017-1-16 21:07
5555~~

我太笨了，理解不了这些代码。。

你楼上的大神不是给你写了代码了吗？

cycyaya

QQ214189912 发表于 2017-1-16 20:17

感谢您的回复，试了不知道为何拆分不了。能不能再帮我看看，万分感谢了