根据Excel的内容和word模板生成对应的word文档

Sub setname()
    Dim I As Integer
    Dim pspname As String
    Dim pspnumber As String
    Dim path As String
    Dim srcPath As String
    Dim srcPath2 As String    Dim wordApp As Object
    Dim wordDoc As Object
    Dim wordArange As Object
    Dim wordSelection As Object
    Dim ReplaceSign As Boolean    Dim Search1 As String
    Dim Search2 As String
    Dim docPrefix As String
    Dim docSuffix As String
    Dim rangSize As Integer    'docPrefix = "-PSP"
    'docSuffix = "采购规格书.doc"
    'Search1 = "电线"
    'Search2 = "6000397-PSP"
    'rangSize = 200    docPrefix = "-TST"
    docSuffix = "入厂检验规格书.doc"
    Search1 = "高压电源"
    Search2 = "6000391-TST"
    rangSize = 1100    For I =  To
        srcPath = "C:\cygwin\tmp\BOM\tst.doc"
        path = "D:\bom\" & ActiveSheet.Cells(I, ) & "-" & ActiveSheet.Cells(I, )
        srcPath2 = path & "\aa.doc"
        pspname = path & "\" & ActiveSheet.Cells(I, ) & docPrefix & " " & ActiveSheet.Cells(I, ) & docSuffix
        pspnumber = ActiveSheet.Cells(I, ) & docPrefix
        MkDir (path)
        FileCopy srcPath, srcPath2
        Name srcPath2 As pspname        Set wordApp = CreateObject("Word.Application")                  '建立WORD实例
        wordApp.Visible = False                                         '屏蔽WORD实例窗体
        Set wordDoc = wordApp.Documents.Open(pspname)                   '打开文件并赋予文件实例
        Set wordSelection = wordApp.Selection                           '定位文件实例
        Set wordArange = wordApp.ActiveDocument.Range(, rangSize)      '指定文件编辑位置
        wordArange.Select                                               '激活编辑位置        Do
            ReplaceSign = wordArange.Find.Execute(Search1, True, , , , , wdReplaceAll, wdFindContinue, , ActiveSheet.Cells(I, ), True)
        Loop Until ReplaceSign = False        Dim rngStory As Object
        Dim lngJunk As Long
        For Each rngStory In wordDoc.StoryRanges
          Do
            ReplaceSign = rngStory.Find.Execute(Search2, True, , , , , wdReplaceAll, wdFindContinue, , pspnumber, True)
            Set rngStory = rngStory.NextStoryRange
          Loop Until rngStory Is Nothing
        Next        wordDoc.Save
        wordDoc.Close True
        wordApp.Quit
    Next I
End Sub

Sub setname()
    Dim I As Integer
    Dim pspname As String
    Dim pspnumber As String
    Dim path As String
    Dim srcPath As String
    Dim srcPath2 As String    Dim wordApp As Object
    Dim wordDoc As Object
    Dim wordArange As Object
    Dim wordSelection As Object
    Dim ReplaceSign As Boolean    Dim Search1 As String
    Dim Search2 As String
    Dim docPrefix As String
    Dim docSuffix As String
    Dim rangSize As Integer    'docPrefix = "-PSP"
    'docSuffix = "采购规格书.doc"
    'Search1 = "电线"
    'Search2 = "6000397-PSP"
    'rangSize = 200    docPrefix = "-TST"
    docSuffix = "-V1.0.doc"
    Search1 = "高压电源"
    Search2 = "6000393-TST"
    rangSize =     For I =  To
        srcPath = "C:\cygwin\tmp\BOM\tst14.doc"
        path = "D:\bom\" & ActiveSheet.Cells(I, ) & "-" & ActiveSheet.Cells(I, )
        srcPath2 = path & "\aa.doc"
        'pspname = path & "\" & ActiveSheet.Cells(I, 3) & docPrefix & " " & ActiveSheet.Cells(I, 4) & docSuffix
        pspname = path & "\" & ActiveSheet.Cells(I, ) & docPrefix & docSuffix
        pspnumber = ActiveSheet.Cells(I, ) & docPrefix
        MkDir (path)
        FileCopy srcPath, srcPath2
        Name srcPath2 As pspname        Set wordApp = CreateObject("Word.Application")                  '建立WORD实例
        wordApp.Visible = False                                         '屏蔽WORD实例窗体
        Set wordDoc = wordApp.Documents.Open(pspname)                   '打开文件并赋予文件实例
        'Set wordSelection = wordApp.Selection                           '定位文件实例
        'Set wordArange = wordApp.ActiveDocument.Range(0, rangSize)      '指定文件编辑位置
        'wordArange.Select                                               '激活编辑位置        'Do
        '    ReplaceSign = wordArange.Find.Execute(Search1, True, , , , , wdReplaceAll, wdFindContinue, , ActiveSheet.Cells(I, 4), True)
        'Loop Until ReplaceSign = False        Dim rngStory As Object
        Dim lngJunk As Long
        For Each rngStory In wordDoc.StoryRanges
          Do
            ReplaceSign = rngStory.Find.Execute(Search2, True, , , , , wdReplaceAll, wdFindContinue, , pspnumber, True)
            Set rngStory = rngStory.NextStoryRange
          Loop Until rngStory Is Nothing
        Next        wordDoc.Save
        wordDoc.Close True
        wordApp.Quit
    Next I
End Sub