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 = 4 To 5
        srcPath = "C:\cygwin\tmp\BOM\tst.doc"
        path = "D:\bom\" & ActiveSheet.Cells(I, 3) & "-" & ActiveSheet.Cells(I, 4)
        srcPath2 = path & "\aa.doc"
        pspname = path & "\" & ActiveSheet.Cells(I, 3) & docPrefix & " " & ActiveSheet.Cells(I, 4) & docSuffix
        pspnumber = ActiveSheet.Cells(I, 3) & 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

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 = 1100

    For I = 70 To 70
        srcPath = "C:\cygwin\tmp\BOM\tst14.doc"
        path = "D:\bom\" & ActiveSheet.Cells(I, 3) & "-" & ActiveSheet.Cells(I, 4)
        srcPath2 = path & "\aa.doc"
        \'pspname = path & "\" & ActiveSheet.Cells(I, 3) & docPrefix & " " & ActiveSheet.Cells(I, 4) & docSuffix
        pspname = path & "\" & ActiveSheet.Cells(I, 3) & docPrefix & docSuffix
        pspnumber = ActiveSheet.Cells(I, 3) & 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