通过vba将execl数据批量录入word文档

lisongmei

凑个热闹练习一下wordvba。。
Sub asd()
Dim wb, arr, sr As String
Set wb = VBA.GetObject(ThisDocument.Path & "\abc\数据源.xlsx")
arr = wb.sheets(1).usedrange.Value
Set wb = Nothing
sr = VBA.Dir(ThisDocument.Path & "\abc\*.doc")
Do While sr <> ""
    flag = False
    h_name = VBA.Split(sr, "_")(1)
    For i = 2 To UBound(arr)
        If arr(i, 3) = h_name Then
            flag = True
            Exit For
        End If
    Next
   
    If flag Then
        Application.ScreenUpdating = False
        Dim w As Document
        Set w = Documents.Open(ThisDocument.Path & "\abc\" & sr)
            With w.Tables(1)
                .Cell(11, 2).Range.Text = arr(i, 4)
                .Cell(14, 2).Range.Text = arr(i, 5)
            End With
            w.Save
            w.Close
            Application.ScreenUpdating = True
    End If
    sr = Dir
Loop

End Sub

同心/ty

lisongmei 发表于 2024-4-7 16:03
凑个热闹练习一下wordvba。。
Sub asd()
Dim wb, arr, sr As String

老师你这个代码应该是指定固定的路径吧！但我要求是跳出提示框自由选择路径选取文件来完成数据填充。测试了一下，也没有运行成功，报错。

同心/ty

wxxydl 发表于 2023-12-30 20:17
已改。。。。。。。。。。。。。。。

老师，一般情况下我的登记簿不放在数据源.xlsm 文件同一目录里，能否帮我修改一下你的代码，让我选择文件夹去选择登记簿写入数据源数据。在盼。也请众多大神帮我！

同心/ty

wxxydl 发表于 2023-12-30 20:17
已改。。。。。。。。。。。。。。。

Sub test()
    Application.ScreenUpdating = False
    Arr = Worksheets("sheet1").UsedRange
    Set doc = CreateObject("word.application")
   
With Application.FileDialog(msoFileDialogFolderPicker)
   '选择文件夹
        If .Show Then
            fp = .SelectedItems(1)
            '选择的文件路径赋值变量fp
        Else
            Exit Sub
            '如果没有选择保存路径，则退出程序
        End If
    End With

f = Dir(fp & "\*.doc")
      Do While f <> ""
        rr = Left(f, 18)
        For i = 1 To UBound(Arr)
            If Arr(i, 2) = rr Then
                s1 = Arr(i, 4)
                s2 = Arr(i, 5)
                Exit For
            End If
        Next
        Set WD = doc.Documents.Open(fp & "\" & f)
        'doc.Visible = True
        With WD.Tables(1)
            .Cell(11, 2) = s1
            .Cell(14, 2) = .Cell(14, 2) & s2
        End With
   
        f = Dir
        WD.Close True
    Loop
    Application.ScreenUpdating = True
    MsgBox "填充完成"
End Sub
老师，采用选取文件夹的方式，我东拼西凑的修改了你的代码，请提出优化宝贵意见。

同心/ty

wxxydl 发表于 2023-12-30 11:38
我给你做了一个  看一下

Sub test()
    Application.ScreenUpdating = False
    Arr = Worksheets("sheet1").UsedRange
    Set doc = CreateObject("word.application")
   
'Set fso = CreateObject("Scripting.FileSystemObject")
Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0)
If Not obmapp Is Nothing Then
fp = obmapp.Self.Path & ""
Else
Exit Sub
End If
f = Dir(fp & "\*.doc")
      Do While f <> ""
        rr = Left(f, 18)
        For i = 1 To UBound(Arr)
            If Arr(i, 2) = rr Then
                s1 = Arr(i, 4)
                s2 = Arr(i, 5)
                Exit For
            End If
        Next
        Set WD = doc.Documents.Open(fp & "\" & f)
        'doc.Visible = True
        With WD.Tables(1)
            .Cell(11, 2) = s1
            .Cell(14, 2) = .Cell(14, 2) & s2
        End With
   
        f = Dir
        WD.Close True
    Loop
    Application.ScreenUpdating = True
    MsgBox "填充完成"
End Sub