EXCEL VBA根据数据生成word文档周报并加背景格式突出显示
EXCEL VBA根据数据生成word文档周报并加背景格式突出显示
Public ww
Sub 生成word()
Dim ww As Worksheet
Dim wj As Worksheet
Dim wz As Worksheet
Dim wb As Workbook
Dim wbf As Workbook
fpath = ThisWorkbook.Path & "\"
fname = Dir(fpath)
hz_str = ""
Do While fname <> ""
If fname <> ThisWorkbook.Name Then
Set 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).Row
If ww.Cells(i, 4) <> "" Then
hz_str = hz_str & "● 【" & ww.Cells(i, 3) & "】" & ww.Cells(i, 2) & " " _
& ww.Cells(i, 4) & Chr(10)
End If
Next
End If
fname = Dir
Loop
wz.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 Then
wz.Range("b4:d4").Clear
wz.Cells(4, 3) = "测算无数据"
Else
wz.Cells(4, "b") = "测算共计"
wz.Cells(4, "d") = "笔,"
End If
Dim WordApp As Object
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
Dim WordD As Object
Set WordD = WordApp.Documents.Add
Set 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 With
End With
With wdTable.cell(1, 1).Range
.Text = "周报"
.Font.Name = "微软雅黑" ' 设置字体
.Font.Size = 20
.Font.Bold = True
.ParagraphFormat.SpaceAfter = 8 ' 设置段后间距为8磅
.ParagraphFormat.LineSpacingRule = 5
.ParagraphFormat.Alignment = 1
End With
Set rng = WordD.Range
rng.Collapse Direction:=0 ' 将Range对象的起始位置移动到当前光标位置
rng.InsertAfter vbCrLf ' 插入一个空行
Set paragraphRange = WordD.Paragraphs(3).Range
With paragraphRange.Font
.Name = "宋体 (中文正文)" ' 设置字体为Calibri
.Size = 10 ' 设置字体大小为14
End With
If wz.Cells(4, 3) = "测算无数据" Then
rng.InsertAfter "测算无数据" & vbCrLf
Else
rng.InsertAfter "测算共计" & wz.Cells(4, 3) & "笔, 合计金额" & _
wz.Cells(4, 6) & "万元。" & vbCrLf
End If
Set paragraphRange = WordD.Paragraphs(4).Range
With paragraphRange.Font
.Name = "宋体" ' 设置字体为Calibri
.Size = 16 ' 设置字体大小为14
End With
' 添加空行
Set paragraphRange = WordD.Paragraphs(5).Range
With paragraphRange.Font
.Name = "宋体 (中文正文)" ' 设置字体为Calibri
.Size = 10.5 '
End With
rng.InsertAfter vbCrLf
rng.InsertAfter "政府工程" & vbCrLf
Set paragraphRange = WordD.Paragraphs(6).Range
With paragraphRange.Font
.Name = "宋体 (中文正文)" ' 设置字体为Calibri
.Size = 10.5
End With
fen_hz_str = Split(hz_str, Chr(10))
For i = 0 To UBound(fen_hz_str) - 1
xx = i + 1 & "." & Right(fen_hz_str(i), Len(fen_hz_str(i)) - 1)
rng.InsertAfter xx & vbCrLf
Set paragraphRange = WordD.Paragraphs(6).Range
With paragraphRange.Font
.Name = "宋体 (中文正文)" ' 设置字体为Calibri
.Size = 10
End With
Next
' 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.Range
rng.Collapse Direction:=0 ' 将Range对象的起始位置移动到当前光标位置
rng.InsertAfter vbCrLf ' 插入一个空行
'.CopyPicture是可以作为图片复制的
With WordD.Content
.Collapse Direction:=0 ' Collapse to the end of the document
wjstrow = wj.Range("a1").End(xlDown).Row
wj.Range("a" & wjstrow & ":d" & wj.Range("d" & wj.Cells.Rows.Count).End(xlUp).Row).Copy ' 复制Excel表格
.PasteExcelTable False, False, True
End With
Set tbl = WordD.Tables(WordD.Tables.Count).Rows(1).Range
tbl.Shading.Texture = wdTextureNone
tbl.Shading.BackgroundPatternColor = RGB(211, 211, 211)
Set tbl = WordD.Tables(WordD.Tables.Count)
For Each col In tbl.Columns
col.Width = 110
Next col
tbl.AutoFitBehavior wdAutoFitWindow
For Each rw In tbl.Rows
rw.Height = 25
Next
'''''''
Application.DisplayAlerts = False
wbf.Close
Application.DisplayAlerts = True
WordD.SaveAs ThisWorkbook.Path & "\周报.docx"
WordD.Close
WordApp.Quit
Call 模块2.HightLight
End Sub
模块2.HightLight
Sub HightLight()
Dim objWord As Object
Dim objDoc
Set objWord = CreateObject("Word.Application")
' Set objWord = GetObject(, "Word.Application")
objWord.Visible = True
Set objDoc = objWord.Documents.Open(ThisWorkbook.Path & "\周报.docx")
objWord.Selection.Find.ClearFormatting
objWord.Selection.Find.Replacement.ClearFormatting
objWord.Selection.Find.Replacement.Highlight = True
With objWord.Selection.Find
.Text = "【*】"
.Replacement.Text = ""
.Forward = True
.Wrap = 0
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchWildcards = True
End With
objWord.Selection.Find.Execute Replace:=2
objDoc.Save
objDoc.Close
objWord.Quit
Set objDoc = Nothing
Set objWord = Nothing
MsgBox "done"
End Sub