将word表内容复制到另一个文档的表格中

buxiaodea

群里的大神，小弟想在excel中将“计划表”中的内容复制到“执行表”中对应的位置，由于实际需要，“计划表”和“执行表”中的工作顺序不一定完全相同，这个代码该怎么写，麻烦指导一下，谢谢！

buxiaodea

求大神指教

gwjkkkkk

Option Explicit
Sub test()
    Dim wdApp As Word.Application, strPlanName$, strExecuteName$
    Dim ar, br$(), i&, j&, r&, strPath$, regEx As Object, Par As Word.Paragraph
   
    strPath = ThisWorkbook.Path & "\"
    strPlanName = strPath & "计划表.docx"
    If Dir(strPlanName) = "" Then MsgBox "计划表不存在，请检查！", vbExclamation: Exit Sub
    strExecuteName = strPath & "执行表.docx"
    If Dir(strExecuteName) = "" Then MsgBox "执行表不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
    ar = Array("电焊", "机修", "抛光")
    Set regEx = CreateObject("VBScript.RegExp")
    regEx.Pattern = "[一二三四五六七八九十]+、"
   
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
   
    With wdApp.documents.Open(strPlanName)
        For Each Par In .Paragraphs
            If regEx.test(Par.Range.Text) Then
                 With Par.Range
                     .Select
                     .End = .End - 1
                      r = r + 1
                      ReDim Preserve br(1 To 2, 1 To r)
                      br(1, r) = Replace(.Text, regEx.Execute(.Text)(0).Value, "")
                        With wdApp.Selection
                            .MoveDown unit:=wdLine
                            .MoveUp unit:=wdParagraph, Extend:=wdExtend
                            .MoveEndUntil vbCr
                            br(2, r) = .Text
                        End With
                 End With
            End If
        Next
        .Close False
    End With
   
    With wdApp.documents.Open(strExecuteName)
        For j = 1 To UBound(br, 2)
            With .Content.Find
                .Text = br(1, j)
                .Forward = True
                .Execute
                If .Found = True Then
                    .Parent.Select
                    With wdApp.Selection
                        .MoveDown unit:=wdLine
                        .MoveUp unit:=wdParagraph, Extend:=wdExtend
                        .MoveEndUntil vbCr
                        .Range.Text = br(2, j)
                    End With
                End If
            End With
        Next j
        .Close True
    End With
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

buxiaodea

gwjkkkkk 发表于 2024-5-6 20:21
请参考附件。。。

厉害厉害，代码有点长，研究一下

gwjkkkkk

buxiaodea 发表于 2024-5-6 20:29
厉害厉害，代码有点长，研究一下

你这个编号有点乱，第一表中 二、抛光 ，第二个表中  二、机修，这个增加了处理难度。。。

buxiaodea

gwjkkkkk 发表于 2024-5-6 20:32
你这个编号有点乱，第一表中 二、抛光 ，第二个表中  二、机修，这个增加了处理难度。。。

就是两张表的顺序调换了一下，是有点麻烦，大神的代码以我现在的水平得好好研究，有点累

buxiaodea

gwjkkkkk 发表于 2024-5-6 20:21
请参考附件。。。

大神好，还是这个调换位置，您的代码太复杂了，看不懂，小弟有个比较简单的想法，但是代码不会写，求指教：我想把这张表中的“三、检查零配件库存”和下面的内容挪到“二、检测机器运行状况”上面，然后想的代码是：通过找到对应段落的位置，将需要调整的内容剪切到目标位置，就是这代码不知道该怎么写，麻烦帮忙一下，谢谢！

gwjkkkkk

Option Explicit
Sub test()
    Dim Rng As Range, Par As Paragraph, n&, i&
   
    With ActiveDocument
        With .Tables(1)
            n = .Range.Cells.Count
            For i = 1 To n
                With .Range.Cells(i)
                    For Each Par In .Range.Paragraphs
                        If InStr(Par.Range.Text, "三、检查零配件库存") Then
                            Set Rng = ActiveDocument.Range(Par.Range.Start, Par.Range.Next(wdParagraph).End)
                            With .Range.Find
                                .Text = "二、检测机器运行状况"
                                .Forward = True
                                .Execute
                                If .Found = True Then
                                     ActiveDocument.Range(.Parent.Start, .Parent.Start).InsertAfter Rng
                                     Rng.Delete
                                End If
                            End With
                            Exit For
                        End If
                    Next Par
                End With
            Next i
        End With
    End With
End Sub

gwjkkkkk

请参考附件，给你写了那么多代码，不给一朵鲜花吗？