VBA的excel逐行替换到word模板及打印还原

滥竽充数砖家，有量没有质的罗列...
vbscript 复制代码
Option Explicit
' 需要在工具->引用库中找到Microsoft word x.xx library勾选上。

Sub ReplaceAndPrint()

    Dim WrkSht As Worksheet
    Set WrkSht = ActiveSheet
    
    Dim RowNumber As Integer
    Dim ColNumber As Integer
    RowNumber = WrkSht.Range("A1").CurrentRegion.Rows.Count
    ColNumber = WrkSht.Range("A1").CurrentRegion.Columns.Count
    
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim excelPath As String
    Dim wordFilePath As String
    Dim j As Integer
    Dim k As Integer
    Dim i As Integer
    Dim colSate As Long, colSime As Long, colLocation As Long, colNumc As Long '用来定位指定列
    ' 查找列位置
    colSate = 0: colSime = 0: colLocation = 0: colNumc = 0
    
    For j = 1 To ColNumber
        Select Case WrkSht.Cells(1, j).Value '第一行的列名循环
            Case "Sate"
                colSate = j
            Case "Sime"
                colSime = j
            Case "Queue Number"
                colLocation = j
            Case "Number"
                colNumc = j
        End Select
    Next j
       
    
    ' 定义替换对照表
    Dim originWords() As String
    Dim replaceWords() As String
    
    ReDim originWords(1 To 4)
    ReDim replaceWords(1 To 4)
    
    originWords(1) = "dd/mm/yyyy"
    originWords(2) = "hh:ss"
    originWords(3) = "queque"
    originWords(4) = "01-B-2111240011"
    
    replaceWords(1) = "pp/pp/mmmm"
    replaceWords(2) = "zz:yy"
    replaceWords(3) = "yueyue"
    replaceWords(4) = "01-B-2111240088"
    

    ' 获取文件路径
    excelPath = ThisWorkbook.Path
    wordFilePath = excelPath & "\猪脚饭1.docx"
    
    ' 检查文件是否存在
    If Dir(wordFilePath) = "" Then
        MsgBox "未找到Word文件：" & wordFilePath
        Exit Sub
    End If
    
    
    ' 创建Word应用
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = True
    
    ' 打开文档
    Set wordDoc = wordApp.Documents.Open(wordFilePath)
    ' 指定打印机
    wordApp.ActivePrinter = "POS80"
    
    ' 一行一行循环替换所有关键词，并打印。
    For k = 2 To RowNumber
        replaceWords(1) = WrkSht.Cells(k, colSate).Value
        replaceWords(2) = WrkSht.Cells(k, colSime).Value
        replaceWords(3) = WrkSht.Cells(k, colLocation).Value
        replaceWords(4) = WrkSht.Cells(k, colNumc).Value
        For i = 1 To UBound(originWords)
            With wordDoc.Range.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Text = originWords(i)
                .Replacement.Text = replaceWords(i)
                .Forward = True
                .Wrap = 1
                .Format = False
                .MatchCase = False
                .MatchWholeWord = False
                .Execute Replace:=2
            End With
        Next i
        ' 打印步骤在此，打印完后word模板还原。
        wordDoc.PrintOut
        Application.Wait Now + TimeValue("0:00:01")
        wordDoc.Undo Times:=4  ' 撤销4步
    Next k

End Sub