自动制作提单

夷陵老祖

由于提单制作量多，特在此求助大神帮忙，望大神不吝赐教，感谢。附件里有两个文件，一个填写好资料后的提单模板，一个是制作要求。

413191246se

楼主，你好！
我觉得你提供的附件中，提单模板 和 制作要求，是一回事！
在我的想象中，附件应该是这个样子的：
1、真实的提单数据源（.docx 文档）一份
2、真实的提单模板文档（.docx 文档）一份（未合并数据源前）
3、真实的提单效果文档（.docx 文档）一份（最好是红色显示）
但你的提单模板是 2003 格式的，提单制作要求是 2007 格式的。
另外，自动提取，是用 VBA 吗？会使用宏吗？有时邮件合并也是可以的。

夷陵老祖

413191246se 发表于 2019-8-14 02:02
楼主，你好！
我觉得你提供的附件中，提单模板 和 制作要求，是一回事！
在我的想象中，附件应该是这个样 ...

感谢您的回答 ，您的理解效果正是我想要表达的。然后宏这边不会制作，会使用，就一个按钮点一下就自动填后的那种，您说的邮件合并方式也可以的，但是要怎么制作呢，请不吝赐教，可以上个附件吗，感谢。

夷陵老祖

       已编辑

夷陵老祖

413191246se 发表于 2019-8-14 02:02
楼主，你好！
我觉得你提供的附件中，提单模板 和 制作要求，是一回事！
在我的想象中，附件应该是这个样 ...

已更新附件

413191246se

* 楼主，我让你提供空白真实提单，仍然没有提供，只好我把已经填好的提单删除再填写。
* 请关闭所有 Word 文档后，单独打开“效果模板.doc”和“数据源.docx”两个文档，按 F8 键执行宏。
* 如果真实的文件名和上述文档不一样，请自行修改，但要注意扩展名；只要文件名正确，本宏就正确。

1. Sub AutoOpen()
   
2.     KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyF8), KeyCategory:=wdKeyCategoryMacro, Command:="提单制作"
   
3. End Sub
   
4. Sub 提单制作()
   
5.     Dim a As Document, b As Document, arr, s&, i&, t$, r$, q$
   
6.    
   
7.     Set a = Documents("效果模板.doc") '短文件名，请自行修改！
   
8.     Set b = Documents("数据源.docx") '短文件名，请自行修改！
   
9. '''
   
10.     b.Activate
    
11.    
    
12.     arr = Split(Left(b.Paragraphs(4).Range, Len(b.Paragraphs(4).Range) - 1), "/")
    
13.     s = UBound(arr)
    
14.    
    
15.     b.Paragraphs(5).Range.Select
    
16.     With Selection
    
17.         Do While Not .Next(4, 1) = vbCr
    
18.             .MoveEnd 4, 1
    
19.         Loop
    
20.         .MoveEnd 1, -1
    
21.         t = .Text
    
22.     End With
    
23.    
    
24.     r = Left(b.Paragraphs(2).Range, Len(b.Paragraphs(2).Range) - 1)
    
25.     q = r
    
26. '''
    
27.     a.Activate
    
28.    
    
29.     ActiveDocument.Range(Start:=a.Tables(1).Range.Cells(2).Range.Paragraphs(5).Range.Characters(InStr(a.Tables(1).Range.Cells(2).Range.Paragraphs(5).Range, ":") + 1).End, End:=a.Tables(1).Range.Cells(2).Range.Paragraphs(5).Range.Characters.Last.End - 1).Text = Left(b.Paragraphs(3).Range.Text, Len(b.Paragraphs(3).Range.Text) - 1)
    
30.     ActiveDocument.Range(Start:=a.Tables(1).Range.Cells(2).Range.Paragraphs(6).Range.Characters(InStr(a.Tables(1).Range.Cells(2).Range.Paragraphs(6).Range, ":") + 1).End, End:=a.Tables(1).Range.Cells(2).Range.Paragraphs(6).Range.Characters.Last.End - 1).Text = Left(b.Paragraphs(3).Range.Text, Len(b.Paragraphs(3).Range.Text) - 1)
    
31.    
    
32.     a.Tables(1).Range.Cells(19).Range.Paragraphs(2).Range.Text = arr(0) & vbCr
    
33.     a.Tables(1).Range.Cells(21).Range.Paragraphs(2).Range.Text = arr(2) & vbCr
    
34.     a.Tables(1).Range.Cells(22).Range.Paragraphs(2).Range.Text = arr(3) & vbCr
    
35.    
    
36.     ActiveDocument.Range(Start:=a.Tables(1).Range.Cells(22).Range.Paragraphs(4).Range.Start, End:=a.Tables(1).Range.Cells(22).Range.Paragraphs.Last.Range.End - 1).Delete
    
37.     a.Tables(1).Range.Cells(22).Range.Paragraphs(3).Range.Characters.Last.InsertBefore Text:=vbCr & t
    
38.    
    
39.     a.Tables(1).Range.Cells(36).Range.Text = r
    
40.     a.Tables(1).Range.Cells(39).Range.Text = r
    
41.     a.Tables(1).Range.Cells(45).Range.Text = r
    
42. '''
    
43.     If Left(r, 1) = "0" Then
    
44.         r = "0" & Mid(r, 2, 1) + 1 & "/" & Right(r, 3)
    
45.     Else
    
46.         r = Left(r, 2) + 1 & "/" & Right(r, 3)
    
47.     End If
    
48. '''
    
49.     If Left(r, 2) = "32" Then MsgBox "错误！本月共32天！请确认数据源是否正确！", 0 + 16: End
    
50. 
    
51.    a.Tables(1).Range.Cells(48).Range.Text = r
    
52.    a.Tables(1).Range.Cells(54).Range.Text = r
    
53.    a.Tables(1).Range.Cells(57).Range.Text = r
    
54. '''
    
55.     q = Replace(q, "/", "-") & "-" & Format(Date, "yyyy")
    
56.     a.Tables(1).Range.Cells(63).Range.Paragraphs(3).Range.Text = q
    
57.     MsgBox "提单制作完毕！请另存为新文档保存！", 0 + 48, "提单制作"
    
58. End Sub

复制代码

夷陵老祖

413191246se 发表于 2019-8-14 23:16
* 楼主，我让你提供空白真实提单，仍然没有提供，只好我把已经填好的提单删除再填写。
* 请关闭所有 Word  ...

我的天 好厉害的样子  感谢您的制作  没能上传空白文档 我的错
请问能不能上传附件  本人小白 不会用这个代码呢

413191246se

楼主，你好！——请按照下面的步骤操作，就可以了！（无须上附件。）
* 打开 Word，在下面的状态条上用鼠标在每个按钮上停顿一下，观察哪个是“录制宏”按钮（可能是最右面的）。
* 点击一下，出现录制宏对话框，点击“确定”，再点击一下刚才的“录制宏”按钮，结束录制。
* 按 Alt + F8 组合键，找到刚才录制的宏“宏1”，点击右边“编辑”按钮，随后光标落在“宏1”宏内。
* 按 Ctrl + End 组合键，将光标移至文尾，将我的代码复制后粘贴于此，然后按右上角最上面的“关闭”按钮关闭代码编辑窗口。
* 关闭所有打开的文档，再将你给我的附件（效果文档 和 数据源）打开，按 F8 试试。
*（如果你实际的文件名和上传的附件文件名不一致，请确认好真实的文件名后，按 Alt + F8 打开宏名列表，找到我给你编程的这个宏名，点击右面“编辑”按钮，就打开了编辑界面（VBE），在我给你编程的这个宏内，头几行代码中，找到：("效果模板.doc") 和("数据源.docx")这两行，用双引号括起来的就是你要处理的两个文档，请自行修改即可）。

413191246se

* 楼主，也可以照下面的步骤进行：（以 Word 2007 为例）
* 点击 Office 球状菜单——（下面）Word 选项——常用——在功能区显示“开发工具”选项卡——确定。
* 点击“开发工具”选项卡——点击第 3 个按钮“录制宏”——出现录制宏对话框——按“确定”关闭窗口——再按“开发工具”选项卡第 3 个按钮“停止录制”，然后，按 Alt + F8 组合键打开宏名列表对话框，找到“宏1”，点击右面“编辑”菜单——进入 VBE——按 Ctrl + End 组合键将光标移至文尾，复制我的代码后粘贴于此，点击右面最上面的“关闭”按钮关闭窗口，再打开你的两个文档“效果文档”和“数据源”文档，按 F8 试试。

413191246se

谢谢 gbgbxgb 老师 夸奖！由于匆忙，没有优化对象，达到目的即可（没什么难度，技术含量低，像一维数组 Split 用法，现到网上找的，没记住怎么用，让老师见笑了；前两天，连简单的函数，还是 daibao88 老师教的）。