自动生成土石方压实报告word版

 

Sub Main()
Dim arExtendAfter()
With Me

ar = .Range("a1").CurrentRegion
ReDim arExtendAfter(1 To UBound(ar), 1 To 20)
For x = 2 To UBound(ar)
If Len(ar(x, 1)) > 0 Then
k = k + 1
For y = 1 To UBound(ar, 2) - 4
arExtendAfter(k, y) = ar(x, y)
Next
End If
Next
Call CreateLastFourColumn(ar, arExtendAfter)
Call MakeWordDocment(arExtendAfter)
End With
MsgBox "OK"
End Sub
Private Sub MakeWordDocment(arExtendAfter)
Dim o As New ExcelDataWriteInWord
Call o.ExcelDataWriteInWord(arExtendAfter, 20, "土方压实度报告(模板)")
End Sub

Private Sub CreateLastFourColumn(ar, arExtendAfter)
k = 1
n = 1
col = 8
For x = 2 To UBound(ar)
k = k + 1
'If k Mod 5 = 0 Then
If k >= 5 Then
ssss = (k - 2) Mod 3
If (k - 2) Mod 3 = 0 Then
col = 8
n = n + 1
End If
End If
For y = 9 To 12
col = col + 1
arExtendAfter(n, col) = ar(x, y)
Next
Next
End Sub

 

Sub ExcelDataWriteInWord(sourceArr, MaxCol, wordModelName)
'根据给定的word模板将Excel表格数据批量写入word
'参数说明
'sourceArr 要写入word的数据源数组
'MaxCol 最大列号
'wordModelName word模板的名称 举例 土方压实度报告(模板)
Dim wordObj As New Word.Application, currentPath$
Dim exportFolderName$, exportPathFolderName$, i, j, Str1, Str2
currentPath = ThisWorkbook.path
For i = 1 To UBound(sourceArr)
If Len(sourceArr(i, 1)) > 0 Then
exportFolderName = wordModelName
FileCopy currentPath & "\土方压实度报告(模板).docx", currentPath & "\" & exportFolderName & "(" & sourceArr(i, 3) & ").docx"
exportPathFolderName = currentPath & "\" & exportFolderName & "(" & sourceArr(i, 3) & ").docx"
KillAlreadyExistsWordFile (exportPathFolderName) '删除已经存在的word文件
FileCopy currentPath & "\土方压实度报告(模板).docx", currentPath & "\" & exportFolderName & "(" & sourceArr(i, 3) & ").docx"
exportPathFolderName = currentPath & "\" & exportFolderName & "(" & sourceArr(i, 3) & ").docx"
With wordObj
.Documents.Open exportPathFolderName
.Visible = False
'For j = 1 To 4 '填写文字数据
For j = 1 To MaxCol '填写文字数据
Str1 = "Data" & Format(j, "000")
If InStr(sourceArr(i, j), ".") > 0 And j > 8 Then
Str2 = Format(sourceArr(i, j), "0.00")
Else
Str2 = sourceArr(i, j)
End If

'Str2 = sourceArr(i, j)
.Selection.HomeKey Unit:=wdStory '光标置于文件首
If .Selection.Find.Execute(Str1) Then '查找到指定字符串
.Selection.Font.Color = wdColorAutomatic '字符为自动颜色
.Selection.Text = Str2 '替换字符串
End If
Next j
End With
wordObj.Documents.Save
' wordObj.Quit
' Set wordObj = Nothing
End If
Next
wordObj.Quit
Set wordObj = Nothing
End Sub
Private Sub KillAlreadyExistsWordFile(path)
If Dir(path) <> "" Then Kill path
End Sub