帮忙修改一下EXCEL转WORD代码修改

pengzhen1817

帮忙修改一下EXCEL数据写入到WORD文档中代码修改

gwjkkkkk

Option Explicit
Sub test()
    Dim ar, i&, j&, wdApp As Word.Application, strFileName$, strPath$, strSaveName$
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "文字日报.doc"
    If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = False
    ar = [A1].CurrentRegion.Value
   
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = New Word.Application
    End If
   
    For i = 2 To UBound(ar)
        With wdApp.documents.Open(strFileName)
            strSaveName = strPath & ar(i, 2)
            For j = 1 To UBound(ar, 2)
                With .Content.Find
                    .ClearFormatting
                    .Text = "数据" & Format(j, "000")
                    .Replacement.ClearFormatting
                    .Replacement.Text = ar(i, j)
                    .Execute Replace:=wdReplaceAll
                End With
            Next j
            .SaveAs strSaveName: .Close
        End With
    Next i
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

重写一个，请参考。。。

pengzhen1817

gwjkkkkk 发表于 2024-8-27 19:28
重写一个，请参考。。。

怎么出现找不到工程或库

gwjkkkkk

office有可能版本不一样，需重新引用一下。。。

pengzhen1817

gwjkkkkk 发表于 2024-8-27 19:57
office有可能版本不一样，需重新引用一下。。。

真不好意思，我找不到怎么引用的，谢谢。

pengzhen1817

gwjkkkkk 发表于 2024-8-27 19:57
office有可能版本不一样，需重新引用一下。。。

出现加载错误

cyq4896

pengzhen1817 发表于 2024-8-28 08:35
出现加载错误

用后期绑试试

gwjkkkkk

pengzhen1817 发表于 2024-8-27 20:12
真不好意思，我找不到怎么引用的，谢谢。

如果后期引用，代码写起来麻烦 一些，请参考。。。

gwjkkkkk

pengzhen1817 发表于 2024-8-28 08:35
出现加载错误

Option Explicit
Sub test()
    Dim ar, br(), r&, i&, j&, k&, wdApp As Object, strFileName$, strPath$, strSaveName$
   
    strPath = ThisWorkbook.Path & "\"
    strFileName = strPath & "文字日报.doc"
    If Dir(strFileName) = "" Then MsgBox "指定的文件不存在，请检查！", vbExclamation: Exit Sub
   
    Application.ScreenUpdating = True
    ar = [A1].CurrentRegion.Value
   
    On Error Resume Next
    Set wdApp = GetObject(, "Word.Application")
    If Err <> 0 Then
        Set wdApp = CreateObject("Word.Application")
    End If
   
    For i = 2 To UBound(ar)
        With wdApp.documents.Open(strFileName)
            strSaveName = strPath & ar(i, 2)
            For j = 1 To UBound(ar, 2)
                Erase br(): r = 0
                With .Content.Find
                    .ClearFormatting
                    .Text = "数据" & Format(j, "000")
                    .Forward = True
                    Do While .Execute
                        r = r + 1
                        ReDim Preserve br(1 To r)
                        Set br(r) = wdApp.ActiveDocument.Range(.Parent.Start, .Parent.End)
                    Loop
                End With
                If r Then
                    For k = 1 To UBound(br)
                        br(k).Text = ar(i, j)
                    Next k
                End If
            Next j
            .SaveAs strSaveName: .Close
        End With
    Next i
   
    If Err <> 0 Then wdApp.Quit
    Set wdApp = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub