EXCEL VBA根据数据生成word文档周报并加背景格式突出显示

本文主要是介绍EXCEL VBA根据数据生成word文档周报并加背景格式突出显示，希望对大家解决编程问题提供一定的参考价值，需要的开发者们随着小编来一起学习吧！

EXCEL VBA根据数据生成word文档周报并加背景格式突出显示

Public wwSub 生成word()Dim ww As WorksheetDim wj As WorksheetDim wz As WorksheetDim wb As WorkbookDim wbf As Workbookfpath = ThisWorkbook.Path & "\"fname = Dir(fpath)hz_str = ""Do While fname <> ""If fname <> ThisWorkbook.Name ThenSet wbf = Workbooks.Open(fpath & fname)Set ww = wbf.Worksheets("文档")Set wj = wbf.Worksheets("金额")Set wz = wbf.Worksheets("周报")For i = 2 To ww.Range("a" & ww.Cells.Rows.Count).End(xlUp).RowIf ww.Cells(i, 4) <> "" Thenhz_str = hz_str & "● 【" & ww.Cells(i, 3) & "】" & ww.Cells(i, 2) & " " _& ww.Cells(i, 4) & Chr(10)End IfNextEnd Iffname = DirLoopwz.Cells(4, 6) = wj.Range("d" & wj.Range("d" & wj.Cells.Rows.Count).End(xlUp).Row)wz.Cells(6, 2) = Left(hz_str, Len(hz_str) - 1)wz.Cells(4, 3) = wj.Range("c" & wj.Range("c" & wj.Cells.Rows.Count).End(xlUp).Row)If wz.Cells(4, 3) = 0 Thenwz.Range("b4:d4").Clearwz.Cells(4, 3) = "测算无数据"Elsewz.Cells(4, "b") = "测算共计"wz.Cells(4, "d") = "笔,"End IfDim WordApp As ObjectSet WordApp = CreateObject("Word.Application")WordApp.Visible = TrueDim WordD As ObjectSet WordD = WordApp.Documents.AddSet wdTable = WordD.Tables.Add(WordD.Range, 1, 1)With wdTable.Borders.Item(1).LineStyle = 0 ' 去掉上边框.Item(4).LineStyle = 0  ' 去掉左边框.Item(2).LineStyle = 0  ' 去掉右边框With .Item(3)           ' 设置底部边框.LineStyle = 1      ' 实线.LineWidth = 12    ' 1.5磅End WithEnd WithWith wdTable.cell(1, 1).Range.Text = "周报".Font.Name = "微软雅黑" ' 设置字体.Font.Size = 20.Font.Bold = True.ParagraphFormat.SpaceAfter = 8 ' 设置段后间距为8磅.ParagraphFormat.LineSpacingRule = 5.ParagraphFormat.Alignment = 1End WithSet rng = WordD.Rangerng.Collapse Direction:=0  ' 将Range对象的起始位置移动到当前光标位置rng.InsertAfter vbCrLf     ' 插入一个空行Set paragraphRange = WordD.Paragraphs(3).RangeWith paragraphRange.Font.Name = "宋体 (中文正文)"        ' 设置字体为Calibri.Size = 10               ' 设置字体大小为14End WithIf wz.Cells(4, 3) = "测算无数据" Thenrng.InsertAfter "测算无数据" & vbCrLfElserng.InsertAfter "测算共计" & wz.Cells(4, 3) & "笔, 合计金额" & _wz.Cells(4, 6) & "万元。" & vbCrLfEnd IfSet paragraphRange = WordD.Paragraphs(4).RangeWith paragraphRange.Font.Name = "宋体"        ' 设置字体为Calibri.Size = 16               ' 设置字体大小为14End With' 添加空行Set paragraphRange = WordD.Paragraphs(5).RangeWith paragraphRange.Font.Name = "宋体 (中文正文)"        ' 设置字体为Calibri.Size = 10.5               'End Withrng.InsertAfter vbCrLfrng.InsertAfter "政府工程" & vbCrLfSet paragraphRange = WordD.Paragraphs(6).RangeWith paragraphRange.Font.Name = "宋体 (中文正文)"        ' 设置字体为Calibri.Size = 10.5End Withfen_hz_str = Split(hz_str, Chr(10))For i = 0 To UBound(fen_hz_str) - 1xx = i + 1 & "." & Right(fen_hz_str(i), Len(fen_hz_str(i)) - 1)rng.InsertAfter xx & vbCrLfSet paragraphRange = WordD.Paragraphs(6).RangeWith paragraphRange.Font.Name = "宋体 (中文正文)"        ' 设置字体为Calibri.Size = 10End WithNext'    Set myrange = WordD.Content
'    myrange.Collapse Direction:=wdCollapseEnd
'    Set wdTable = WordD.Tables.Add(myrange, 1, 1)
'    For i = 0 To UBound(fen_hz_str) - 1
'        x = x & Chr(11) & i + 1 & "." & Right(fen_hz_str(i), Len(fen_hz_str(i)) - 1)
'    Next
'
'    With wdTable.cell(1, 1).Range
'        .Text = Right(x, Len(x) - 1)
'        .Font.Name = "宋体" ' 设置字体
'        .Font.Size = 9
'        .ParagraphFormat.SpaceAfter = 8 ' 设置段后间距为8磅
'        .ParagraphFormat.LineSpacingRule = 5
'    End With
'Set rng = WordD.Rangerng.Collapse Direction:=0  ' 将Range对象的起始位置移动到当前光标位置rng.InsertAfter vbCrLf     ' 插入一个空行'.CopyPicture是可以作为图片复制的With WordD.Content.Collapse Direction:=0 ' Collapse to the end of the documentwjstrow = wj.Range("a1").End(xlDown).Rowwj.Range("a" & wjstrow & ":d" & wj.Range("d" & wj.Cells.Rows.Count).End(xlUp).Row).Copy ' 复制Excel表格.PasteExcelTable False, False, TrueEnd WithSet tbl = WordD.Tables(WordD.Tables.Count).Rows(1).Rangetbl.Shading.Texture = wdTextureNonetbl.Shading.BackgroundPatternColor = RGB(211, 211, 211)Set tbl = WordD.Tables(WordD.Tables.Count)For Each col In tbl.Columnscol.Width = 110Next coltbl.AutoFitBehavior wdAutoFitWindowFor Each rw In tbl.Rowsrw.Height = 25Next'''''''Application.DisplayAlerts = Falsewbf.CloseApplication.DisplayAlerts = TrueWordD.SaveAs ThisWorkbook.Path & "\周报.docx"WordD.CloseWordApp.QuitCall 模块2.HightLightEnd Sub

模块2.HightLight

Sub HightLight()Dim objWord As ObjectDim objDocSet objWord = CreateObject("Word.Application")
'    Set objWord = GetObject(, "Word.Application")objWord.Visible = TrueSet objDoc = objWord.Documents.Open(ThisWorkbook.Path & "\周报.docx")objWord.Selection.Find.ClearFormattingobjWord.Selection.Find.Replacement.ClearFormattingobjWord.Selection.Find.Replacement.Highlight = TrueWith objWord.Selection.Find.Text = "【*】".Replacement.Text = "".Forward = True.Wrap = 0.Format = True.MatchCase = False.MatchWholeWord = False.MatchByte = False.MatchAllWordForms = False.MatchSoundsLike = False.MatchWildcards = TrueEnd WithobjWord.Selection.Find.Execute Replace:=2objDoc.SaveobjDoc.CloseobjWord.QuitSet objDoc = NothingSet objWord = NothingMsgBox "done"
End Sub