ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 3485|回复: 26

[求助] 自动制作提单

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-8-13 12:09 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
由于提单制作量多,特在此求助大神帮忙,望大神不吝赐教,感谢。附件里有两个文件,一个填写好资料后的提单模板,一个是制作要求。

自动制作提单.zip

71.24 KB, 下载次数: 34

TA的精华主题

TA的得分主题

发表于 2019-8-14 02:02 | 显示全部楼层
楼主,你好!
我觉得你提供的附件中,提单模板 和 制作要求,是一回事!
在我的想象中,附件应该是这个样子的:
1、真实的提单数据源(.docx 文档)一份
2、真实的提单模板文档(.docx 文档)一份(未合并数据源前)
3、真实的提单效果文档(.docx 文档)一份(最好是红色显示)
但你的提单模板是 2003 格式的,提单制作要求是 2007 格式的。
另外,自动提取,是用 VBA 吗?会使用宏吗?有时邮件合并也是可以的。

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-8-14 09:50 | 显示全部楼层
413191246se 发表于 2019-8-14 02:02
楼主,你好!
我觉得你提供的附件中,提单模板 和 制作要求,是一回事!
在我的想象中,附件应该是这个样 ...

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-8-14 10:03 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 夷陵老祖 于 2019-8-16 16:46 编辑

       已编辑

自动制作提单更新版.zip

96.42 KB, 下载次数: 26

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-8-14 10:04 | 显示全部楼层
413191246se 发表于 2019-8-14 02:02
楼主,你好!
我觉得你提供的附件中,提单模板 和 制作要求,是一回事!
在我的想象中,附件应该是这个样 ...

已更新附件

TA的精华主题

TA的得分主题

发表于 2019-8-14 23:16 | 显示全部楼层
* 楼主,我让你提供空白真实提单,仍然没有提供,只好我把已经填好的提单删除再填写。
* 请关闭所有 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.    a.Tables(1).Range.Cells(48).Range.Text = r
  51.    a.Tables(1).Range.Cells(54).Range.Text = r
  52.    a.Tables(1).Range.Cells(57).Range.Text = r
  53. '''
  54.     q = Replace(q, "/", "-") & "-" & Format(Date, "yyyy")
  55.     a.Tables(1).Range.Cells(63).Range.Paragraphs(3).Range.Text = q
  56.     MsgBox "提单制作完毕!请另存为新文档保存!", 0 + 48, "提单制作"
  57. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

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

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

TA的精华主题

TA的得分主题

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

TA的精华主题

TA的得分主题

发表于 2019-8-16 22:39 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
* 楼主,也可以照下面的步骤进行:(以 Word 2007 为例)
* 点击 Office 球状菜单——(下面)Word 选项——常用——在功能区显示“开发工具”选项卡——确定。
* 点击“开发工具”选项卡——点击第 3 个按钮“录制宏”——出现录制宏对话框——按“确定”关闭窗口——再按“开发工具”选项卡第 3 个按钮“停止录制”,然后,按 Alt + F8 组合键打开宏名列表对话框,找到“宏1”,点击右面“编辑”菜单——进入 VBE——按 Ctrl + End 组合键将光标移至文尾,复制我的代码后粘贴于此,点击右面最上面的“关闭”按钮关闭窗口,再打开你的两个文档“效果文档”和“数据源”文档,按 F8 试试。

TA的精华主题

TA的得分主题

发表于 2019-8-16 22:40 | 显示全部楼层
本帖最后由 413191246se 于 2019-8-16 22:57 编辑

谢谢 gbgbxgb 老师 夸奖!由于匆忙,没有优化对象,达到目的即可(没什么难度,技术含量低,像一维数组 Split 用法,现到网上找的,没记住怎么用,让老师见笑了;前两天,连简单的函数,还是 daibao88 老师教的)。
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 04:09 , Processed in 0.053641 second(s), 11 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表