给位大神，能否帮忙写下代码，Excel中数字对应到Word模板上位置

caiqizhong21

给位大神！您们好，由于小弟日常工作，需要在Excel数据中大量筛选后，把需要的数字或文本，在录制到已做好的Word模板中，每天工作量很大也，望哪位大神帮忙写下代码，实现轻松快捷工作。小弟先在此谢谢！

chenbiao2012

在excel中设计联结,把生成文字复制粘帖更省事

lilyhcn1

你这不就是简单的excel生成word吗，找找很多啊

caiqizhong21

lilyhcn1 发表于 2019-12-12 21:40
你这不就是简单的excel生成word吗，找找很多啊

是的，找了几个相似的好像都不是我要的，还是我比较笨不会变通

魂断蓝桥

Sub a()
    Dim appWD, doc As Object, arr, i%, RAN, m&
    Set appWD = CreateObject("Word.Application")
    arr = [a1].CurrentRegion
    Set doc = appWD.Documents.Open(ThisWorkbook.Path & "\word.doc")
    appWD.Visible = True
    Set RAN = doc.Range
    With RAN.Find
        .ClearFormatting
        For i = 2 To UBound(arr)
            If arr(i, 2) <> "" Then
                .Text = arr(i, 3)
                .Wrap = 1
                If .Execute Then
                    m = RAN.End
                    doc.Range(m, m).InsertBefore arr(i, 2)
                    doc.Range(m - Len(arr(i, 3)), m).Delete
                End If
            Else
                doc.Close True
                appWD.Quit
                Exit Sub
            End If
        Next
    End With
End Sub

caiqizhong21

魂断蓝桥 发表于 2019-12-13 10:26
Sub a()
    Dim appWD, doc As Object, arr, i%, RAN, m&
    Set appWD = CreateObject("Word.Applicat ...

大神膜拜，五体投地 真心膜拜！！真厉害，魂断蓝桥老师

caiqizhong21

魂断蓝桥 发表于 2019-12-13 10:26
Sub a()
    Dim appWD, doc As Object, arr, i%, RAN, m&
    Set appWD = CreateObject("Word.Applicat ...

老师，能不能循环替换，比如Word中[1]这个位置同时出现了，好几次，只能替换第一个，后面出现的[1]这个位置就无法替换Excel中的内容了，请您有空帮忙看下

魂断蓝桥

caiqizhong21 发表于 2019-12-13 18:31
老师，能不能循环替换，比如Word中[1]这个位置同时出现了，好几次，只能替换第一个，后面出现的[1]这个位 ...

Option Explicit

Sub a()
    Dim appWD, doc As Object, arr, i%, RAN, m&
    Set appWD = CreateObject("Word.Application")
    arr = [a1].CurrentRegion
    Set doc = appWD.Documents.Open(ThisWorkbook.Path & "\word.doc")
    'appWD.Visible = True
    Set RAN = doc.Range
    With RAN.Find
        .ClearFormatting
        .wrap = 1
        For i = 2 To UBound(arr)
            If arr(i, 2) <> "" Then
                .Text = arr(i, 3)
                If .Execute Then
                    .Replacement.Text = arr(i, 2)
                    .Execute Replace:=2
                End If
            Else
                doc.Close True
                appWD.Quit
                Exit Sub
            End If
        Next
    End With
End Sub

caiqizhong21

魂断蓝桥 发表于 2019-12-16 08:52
Option Explicit

Sub a()

好像不行 老师，你能不能再我样本上 写好发下，，我小白，自己复制代码感觉还是不能替换所有 还是有个别的漏项没替换掉