|
|
Sub 批量word()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ar As Variant
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set wdWORD = CreateObject("Word.Application") '定义- -个Word对象变量
wdWORD.Visible = True
mb = ThisWorkbook.Path & "\模版.docx"
With Sheets("Sheet1")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:g" & r)
End With
For i = 2 To UBound(ar)
If Trim(ar(i, 2)) <> "" Then
d(Trim(ar(i, 2))) = ""
End If
Next i
rr = Array(1, 3, 7, 1, 1, 1)
For Each k In d.keys
n = 0
ReDim br(1 To UBound(ar), 1 To 6)
For i = 2 To UBound(ar)
If Trim(ar(i, 2)) = k Then
n = n + 1
br(n, 1) = n
br(n, 2) = ar(i, 3)
br(n, 3) = ar(i, 5)
br(n, 4) = ar(i, 7)
br(n, 5) = ar(i, 6)
End If
Next i
FileCopy mb, ThisWorkbook.Path & "\" & k & ".docx"
Set dkDOC = wdWORD.Documents.Open(ThisWorkbook.Path & "\" & k & ".docx") '* 创建文档对象
With wdWORD
.Selection.HomeKey unit:=6 'wdStory '光标置于文件首
If .Selection.Find.Execute("sj1") Then '查找到指定字符串
.Selection.Text = k '替换字符串
End If
.Selection.endkey unit:=6 '''光标定位文件末尾
'.Selection.TypeParagraph '''光标下移一行
.activedocument.Tables.Add Range:=.Selection.Range, NumRows:=n + 1, NumColumns:=6 '插入表格
End With
Set wdBG = wdWORD.activedocument.Tables(1) '(1) '创建表格对象
With wdBG '表格写入文本
If .Style <> "网格型" Then
.Style = "网格型"
End If
For s = 0 To UBound(rr)
.Columns(s + 1).Width = Application.CentimetersToPoints(rr(s))
Next s '''设置表格各列宽度
.cell(1, 1) = "序号"
.cell(1, 2) = "产品描述"
.cell(1, 3) = "物料描述"
.cell(1, 4) = "单位"
.cell(1, 5) = "数量"
.cell(1, 6) = "备注"
For i = 1 To n
For j = 1 To 5
.cell(i + 1, j) = br(i, j)
Next j
Next i
With .Range '表格
.Font.Bold = True ''字型加粗
.Font.Size = 8 '字号
.Font.Name = "宋体" '字体
.ParagraphFormat.Alignment = 1 'wdAlignParagraphCenter '' 等于0 则左对齐，等于1居中显示
End With
End With
dkDOC.SaveAs Filename:=ThisWorkbook.Path & "\" & k & ".docx"
dkDOC.Close
Next k
wdWORD.Quit
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2023-6-30 14:45
楼主
