将word文档A表格中的内容拷贝到word文档B表格中

Function IsFileExists(ByVal strFileName As String) As Boolean
    If Dir(strFileName, 16) <> Empty Then
        IsFileExists = True
    Else
        IsFileExists = False
    End If
End Function

Sub setname()
    Dim I As Integer
    Dim J As Integer
    Dim pspname As String
    Dim pspnumber As String
    Dim tstname As String
    Dim tstnumber As String
    Dim path As String
    Dim srcPath As String
    Dim srcPath2 As String
    Dim headName As String
    Dim headName2 As String
    Dim txthead As String
    
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim wordDoc2 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
    Dim stringTable1 As String
    
        
    'docPrefix = "-PSP"
    'docSuffix = "采购规格书.doc"
    'Search1 = "电线"
    'Search2 = "6000397-PSP"
    'rangSize = 200
    
    docPrefix = "-"
    docSuffix = "入场检验报告.doc"
    Search1 = "高压电源"
    Search2 = "6000000-TST"
    'Search1 = "AC-DC开关电源"
    'Search2 = "6000412-TST"
    rangSize = 60
    
    J = 1
    Dim myItem
    'myItem = Array(14, 16, 17, 18, 22, 23, 24, 26, 27, 31, 32, 33, 34, 35, 36, 48, 50, 55, 56, 62, 63, 64, 65, 66, 67, 68, 69, 71, 73, 77, 79, 102, 114, 126, 127, 128, 129, 130, 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, 161, 162, 163, 164, 165, 166, 167, 168, 172, 173, 174, 175, 176, 177, 179, 180, 181)
    For I = 1 To 187
        'srcPath = "C:\cygwin\tmp\BOM\tst16.doc"
        'If ActiveSheet.Cells(I, 5) = "" Then
        '    headName2 = ActiveSheet.Cells(I, 3) & "-" & ActiveSheet.Cells(I, 4) & "-" & ActiveSheet.Cells(I, 5)
        '    headName = headName2 & docSuffix
        '    headName3 = ActiveSheet.Cells(I, 4)
        'Else
        '    headName2 = ActiveSheet.Cells(I, 3) & "-" & ActiveSheet.Cells(I, 4) & "-" & ActiveSheet.Cells(I, 6)
        '    headName = headName2 & docSuffix
        '    headName3 = ActiveSheet.Cells(I, 4) & "（" & ActiveSheet.Cells(I, 5) & "）"
        'End If
        'headName = Replace(headName, "/", "-")
        path = "D:\bom\"
        srcPath2 = path & "\aa.doc"
        'pspname = path & "\" & ActiveSheet.Cells(I, 3) & docPrefix & ActiveSheet.Cells(I, 4) & docSuffix
        pspname = "D:\bom\" & ActiveSheet.Cells(I, 3) & "-PSP-V1.0.doc"
        tstname = "D:\bom\" & ActiveSheet.Cells(I, 3) & "-TST-V1.0.doc"
        tstnumber = ActiveSheet.Cells(I, 3) & "-TST"
        
        headName = ActiveSheet.Cells(I, 4)
        headName2 = ActiveSheet.Cells(I, 3)
        
        pspname2 = "D:\bom\aa\" & ActiveSheet.Cells(I, 3) & "-PSP-V1.0.doc"
        
        If IsFileExists(pspname) = True Then
            'FileCopy srcPath, srcPath2
            'Name srcPath2 As tstname
            'headName = ActiveSheet.Cells(I, 4).Value
            'headName2 = ActiveSheet.Cells(I, 3)
            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                                               '激活编辑位置
            
            'stringTable1 = wordDoc.Tables(4).Cell(2, 1)
            
            Set wordDoc2 = wordApp.Documents.Open(pspname2)
            'stringTable1 = Trim(wordDoc.Tables(1).Cell(2, 2).Range.Text)
            'wordDoc2.Tables(1).Cell(2, 2) = wordDoc.Tables(1).Cells(2, 2)
            wordDoc2.Tables(1).Cell(2, 2).Range.Text = Replace(wordDoc.Tables(1).Cell(2, 2).Range.Text, Chr(13), "")
            wordDoc2.Tables(1).Cell(2, 3).Range.Text = Replace(wordDoc.Tables(1).Cell(2, 3).Range.Text, Chr(13), "")
            
            wordDoc2.Tables(1).Cell(3, 2).Range.Text = Replace(wordDoc.Tables(1).Cell(3, 2).Range.Text, Chr(13), "")
            wordDoc2.Tables(1).Cell(3, 3).Range.Text = Replace(wordDoc.Tables(1).Cell(3, 3).Range.Text, Chr(13), "")
            
            wordDoc2.Tables(1).Cell(4, 2).Range.Text = Replace(wordDoc.Tables(1).Cell(4, 2).Range.Text, Chr(13), "")
            wordDoc2.Tables(1).Cell(4, 3).Range.Text = Replace(wordDoc.Tables(1).Cell(4, 3).Range.Text, Chr(13), "")
            
            wordDoc2.Tables(2).Cell(1, 4).Range.Text = headName2
            wordDoc2.Tables(2).Cell(2, 4).Range.Text = "件"
            'wordDoc2.Tables(2).Cell(2, 2).Range.Text = Replace(wordDoc.Tables(2).Cell(3, 2).Range.Text, Chr(13), "")
            wordDoc2.Tables(2).Cell(3, 2).Range.Text = Replace(wordDoc.Tables(2).Cell(4, 2).Range.Text, Chr(13), "")
            wordDoc2.Tables(2).Cell(3, 4).Range.Text = Replace(wordDoc.Tables(2).Cell(3, 2).Range.Text, Chr(13), "")
            
            wordDoc2.Tables(3).Cell(2, 1).Range = wordDoc.Tables(4).Cell(2, 1).Range
            
            wordDoc.Save
            wordDoc.Close True
            wordDoc2.Save
            wordDoc2.Close True
            wordApp.Quit
            J = J + 1
        End If
    Next I

End Sub

特别注意 Chr(13)是文档中的换行符。