第1个回答 2020-11-13
Sub Execl_to_Word()
Dim wordApp As Object, newdoc As Object
Dim lt(8) As Object
Dim rg_publishtime As Range
Dim curow As Long
Dim counter_i As Integer
Dim sign_II As Boolean, sign_III As Boolean, sign_IV As Boolean, sign_VII As Boolean, sign_VIII As Boolean
Rem 创建新的WORD应用程序并新建文档
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = True
Set newdoc = wordApp.documents.Add
Rem 设置页面布局
With newdoc.PageSetup
Rem 纸张方向
.Orientation = 0 'wdOrientPortrait
Rem 页边距
.TopMargin = Application.CentimetersToPoints(2)
.BottomMargin = Application.CentimetersToPoints(2)
.LeftMargin = Application.CentimetersToPoints(1.9)
.RightMargin = Application.CentimetersToPoints(1.9)
Rem 额外页边距（供装订）
.Gutter = Application.CentimetersToPoints(0)
Rem 页眉页脚
.HeaderDistance = Application.CentimetersToPoints(1.5)
.FooterDistance = Application.CentimetersToPoints(1.75)
Rem 纸张大小
.PageWidth = Application.CentimetersToPoints(21)
.PageHeight = Application.CentimetersToPoints(29.7)
Rem 分页符类型
.SectionStart = 0 'wdSectionContinuous
Rem 奇偶页页眉页脚是否不同
.OddAndEvenPagesHeaderFooter = False
Rem 首页页眉页脚是否不同
.DifferentFirstPageHeaderFooter = False
Rem 文本对齐方式
.VerticalAlignment = 0 'wdAlignVerticalTop
Rem 装订线位置
.GutterPos = 0 'wdGutterPosLeft
Rem 文档版式模式
.LayoutMode = 2 'wdLayoutModeLineGrid
End With
Rem 自定义列表样式
For counter_i = 1 To 8
Set lt(counter_i - 1) = newdoc.ListTemplates.Add
With lt(counter_i - 1).ListLevels(1)
Select Case counter_i
Case 1
.NumberFormat = "%1、"
.NumberStyle = 37 'wdListNumberStyleSimpChinNum1
.Font.Name = ""
Case 2
.NumberFormat = "(%1)"
.NumberStyle = 39 'wdListNumberStyleSimpChinNum3
.Font.Name = ""
Case 3
.NumberFormat = "%1."
.NumberStyle = 0 'wdListNumberStyleArabic
.Font.Name = ""
Case 4
.NumberFormat = "%1)"
.NumberStyle = 0 'wdListNumberStyleArabic
.Font.Name = ""
Case 5
.NumberFormat = ChrW(61656)
.NumberStyle = 23 'wdListNumberStyleBullet
.Font.Name = "wingdings"
Case 6
.NumberFormat = ChrW(61692)
.NumberStyle = 23 'wdListNumberStyleBullet
.Font.Name = "wingdings"
Case 7
.NumberFormat = "%1."
.NumberStyle = 0 'wdListNumberStyleArabic
.Font.Name = ""
Case Else
.NumberFormat = "%1)"
.NumberStyle = 0 'wdListNumberStyleArabic
.Font.Name = ""
End Select
.TrailingCharacter = 0 'wdTrailingTab
.NumberPosition = Application.CentimetersToPoints(0)
.Alignment = 0 'wdListLevelAlignLeft
.TextPosition = Application.CentimetersToPoints(0)
.ResetOnHigher = False '延续编号
End With
Next
sign_II = True
sign_III = True
sign_IV = True
sign_VII = True
sign_VIII = True
curow = 1
On Error Resume Next
Set rg_publishtime = Report.Range("A:A").Find("*发布日期*")
If rg_publishtime Is Nothing Then
MsgBox "未找到 *发布日期* 标识", vbOKOnly, "提示"
Exit Sub
End If
While curow <= rg_publishtime.Row + 1
If Report.Range("A" & curow).Value <> "" And Report.Range("A" & curow).Font.Color = RGB(0, 0, 0) Then
If Report.Range("A" & curow).Value = "表格" Then
Rem 复制表格区域
Report.Range(Report.Range("F" & curow), Report.Cells(curow + Report.Range("A" & curow).MergeArea.Rows.Count - 1, Range("F" & curow).Column + Report.Range("F" & curow).MergeArea.Columns.Count + tblc(Report.Range("F" & curow)) - 1)).Copy
Rem 粘贴到WORD里
newdoc.Paragraphs(newdoc.Paragraphs.Count).Range.pasteExceltable False, False, False
Rem 设置表格格式
With newdoc.Tables(newdoc.Tables.Count)
With .Range.Font
.Name = Report.Range("B" & curow).Value
.Size = Report.Range("C" & curow).Value
End With
.AutoFitBehavior (1) 'wdAutoFitContent
.AutoFitBehavior (2) 'wdAutoFitWindow
.Rows.HeightRule = wdRowHeightAtLeast
.Rows.Height = Application.CentimetersToPoints(0)
End With
Rem 增加一个新段落供后续粘贴使用
'newdoc.Paragraphs.Add
Rem 供后续粘贴使用的段落清除掉从上文继承的列表格式
newdoc.Paragraphs(newdoc.Paragraphs.Count).Range.ListFormat.RemoveNumbers
Rem 左对齐
newdoc.Paragraphs(newdoc.Paragraphs.Count).Alignment = 0 'wdAlignParagraphLeft
Else
With newdoc.Paragraphs(newdoc.Paragraphs.Count)
With .Range.Font
.Name = Report.Range("B" & curow).Value
.Size = Report.Range("C" & curow).Value
.Bold = Report.Range("F" & curow).Font.Bold
End With
Rem 为粘贴的段落内容设置列表样式
Select Case Report.Range("A" & curow).Value
Case "样式:一、"
.Range.ListFormat.ApplyListTemplate lt(0), True, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_II = False
Case "样式:(一)"
.Range.ListFormat.ApplyListTemplate lt(1), sign_II, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_II = True
sign_III = False
Case "样式:1."
.Range.ListFormat.ApplyListTemplate lt(2), sign_III, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_III = True
sign_IV = False
Case "样式:1)"
.Range.ListFormat.ApplyListTemplate lt(3), sign_IV, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_IV = True
Case "样式:≯"
.Range.ListFormat.ApplyListTemplate lt(4), True, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_VII = False
sign_VIII = False
Case "样式:√"
.Range.ListFormat.ApplyListTemplate lt(5), True, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
Case "样式:≯1"
.Range.ListFormat.ApplyListTemplate lt(6), sign_VII, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_VII = True
Case "样式:≯1)"
.Range.ListFormat.ApplyListTemplate lt(7), sign_VIII, wdListApplyToWholeList, wdWord10ListBehavior
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
sign_VIII = True
Case "正文"
.CharacterUnitLeftIndent = Report.Range("D" & curow).Value '左缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = Report.Range("E" & curow).Value '悬挂缩进
Case "***标题***"
.Alignment = 1 '标题居中：wdAlignParagraphCenter
Case "***署名***"
.Alignment = 2 '署名右对齐：wdAlignParagraphRight
Case "*发布日期*"
.Range.ParagraphFormat.RightIndent = Application.CentimetersToPoints(0.75)
.Alignment = 2 '发布日期右对齐：wdAlignParagraphRight
Case Else
End Select
Rem 粘贴内容并设置所粘内容的格式
counter_i = 0
While Report.Range("F" & curow).Offset(0, counter_i).Value <> ""
Rem 粘贴内容
.Range.InsertAfter Report.Range("F" & curow).Offset(0, counter_i).Value
Rem 为粘贴内容设置字体格式
With newdoc.Range(.Range.End - 1 - Len(Report.Range("F" & curow).Offset(0, counter_i).Value), .Range.End - 1).Font
.Name = Report.Range("B" & curow).Value
.Size = Report.Range("C" & curow).Value
.Bold = Report.Range("F" & curow).Offset(0, counter_i).Font.Bold
End With
counter_i = counter_i + 1
Wend
Rem 增加一个新段落供后续粘贴使用
newdoc.Paragraphs.Add
Rem 供后续粘贴使用的段落清除掉从上文继承的列表格式
.Range.ListFormat.RemoveNumbers
Rem 左对齐
.Alignment = 0 'wdAlignParagraphLeft
.CharacterUnitLeftIndent = 0 '取消缩进
.Range.ParagraphFormat.CharacterUnitFirstLineIndent = 0 '悬挂缩进2字符
End With
End If
End If
Rem 定位下一粘贴内容所在单元格
curow = curow + Report.Range("A" & curow).MergeArea.Rows.Count
Wend
counter_i = MsgBox("导出成功！请问是否需要保存", vbYesNo, "恭喜！")
If counter_i = 6 Then
newdoc.SaveAs (ThisWorkbook.Path + "\" + Range("B1").Value + Range("B2").Value + "周报.docx")
End If
Rem 清理内存
For counter_i = 1 To 8
Set lt(counter_i - 1) = Nothing
Next
Set newdoc = Nothing
Set wordApp = Nothing
Set rg_publishtime = Nothing
curow = 0
counter_i = 0
sign_II = False
sign_III = False
sign_IV = False
sign_VII = False
sign_VIII = False
End Sub
Private Function tblc(ByRef rg As Range) As Long
Dim curg As Range
Set curg = rg.Offset(0, 1)
tblc = 0
While curg.Value <> ""
tblc = tblc + curg.MergeArea.Columns.Count
Set curg = curg.Offset(0, 1)
Wend
Set curg = Nothing
End Function本回答被网友采纳