Excel与word交互读取内容

奋斗吧

擅长邻域：未填写

2023-05-23 18:24:02 196浏览

Excel与word交互读取内容，日常审计工作中，经常有Excel表格批量复制到Word的需求。excel善于计算分析，但是最后的报告都是以word形式展示的。经常我们手动修改excel数据，想让word页跟随更新。几十个表格复制粘贴是非常麻烦的，那么有没有快点的办法实现一键操作呢？答案是：有的。我们可以借助VBA去简化步骤。一、操作步骤：首先我们需要预处理我们的表格和word模板。1.1、Excel需要做的工作:为需要粘贴到wo

日常审计工作中，经常有Excel表格批量复制到Word的需求。excel善于计算分析，但是最后的报告都是以word形式展示的。经常我们手动修改excel数据，想让word页跟随更新。

几十个表格复制粘贴是非常麻烦的，那么有没有快点的办法实现一键操作呢？

Excel与word交互读取内容_VBA

Excel与word交互读取内容_Word_02

答案是：有的。我们可以借助VBA去简化步骤。

一、操作步骤：

首先我们需要预处理我们的表格和word模板。

1.1、Excel需要做的工作:

为需要粘贴到word的区域建立区域名称，比如下面这个区域

Excel与word交互读取内容_Word_03

需要复制多少个区域，我们就新建多少个名称。

这种方式有一个很大的优点：当我们新增行、删除行。这个区域名称指向的是我们修改过的新区域。

这样的话，无论我们怎么修改excel区域，都是随时更新的~

1.2、Word需要做的工作:

我们在word中新建相应的书签，在表格需要插入的位置，插入书签。要保证和excel中的名称是一对一的关系。

Excel与word交互读取内容_Word_04

二、代码编写：

准备工作做好之后，我们就可以编写我们的代码了。这里我直接把代码结果给出。代码能够实现一键刷新excel中的数据表格到word相应区域~

2.1、源代码

    '主程序
    Public xlapp
Public Sub MergeToWord()
    '打开Word
    'On Error Resume Next
    Set xlapp = GetObject(, "Excel.Application")
    If Err <> 0 Then
        MsgBox "请检查Excel文档是否是打开的"
        Exit Sub
    End If
    '获取活动文档
    Set wb = xlapp.ActiveWorkbook
    If Err <> 0 Then
        MsgBox "连接到当前Excel文档时错误: " & Err.Message
        Exit Sub
    End If
    On Error GoTo 0
    '处理表和图表
    '在Word中查找所有相关标签并处理它们
    ReDim B(ActiveDocument.Bookmarks.Count) As Object
    Dim i As Long
    '在数组中存储标签, 然后逐一处理它们
    '不能遍历它们因为当发生粘贴时Word销毁了它们
    For i = 1 To ActiveDocument.Bookmarks.Count
        Set B(i) = ActiveDocument.Bookmarks(i)
    Next i
    '//////////遍历当前excel中的所有【自定义名称】，校核//////////////
    Set d = CreateObject("scripting.dictionary")
    For Each oName In xlapp.ActiveWorkbook.Names
        d(oName.Name) = ""
    Next
    For i = 1 To UBound(B)
        If d.Exists(B(i).Name) Then
            d.Remove (B(i).Name)
        End If
    Next
    If d.Count > 0 Then
    krr = d.keys
    MsgBox "excel中以下名称不存在，需要校核:" & vbCrLf & Join(krr, vbCrLf)
    
        Exit Sub
    End If
    '/////////////////////////////////////////////////////////////////
    '处理它们
    For i = 1 To UBound(B)
        PasteToWord B(i)
    Next
    MsgBox "完成~"
End Sub
    '处理Word标签
Private Sub PasteToWord(B As Object, Optional Method As String = "Metafile")    '  tag As String)
    'On Error Resume Next
    Dim strTag As String
    Dim tag As String
    strTag = B.Name
    If Err <> 0 Then Exit Sub
    On Error GoTo 0
    '选择书签区域
    B.Range.Select
    '标记书签的开始
    Dim rngMark As Object
    Set rngMark = Selection.Range
    rngMark.Collapse 1
    PasteTableToWord xlapp, B
End Sub
    '粘贴表
    '标签必须作为Excel中的区域存在才能使其工作
Private Sub PasteTableToWord(xlapp, B As Object)
    Dim strTag As String
    'On Error Resume Next
    strTag = B.Name
    If Err <> 0 Then Exit Sub
    On Error GoTo 0
    Dim tblTag As String
    Dim u As Long
    tblTag = strTag
    'On Error Resume Next
    xlapp.Range(tblTag).Copy
    If Err = 0 Then
        With Selection
            If .Tables.Count = 1 Then                          '更新前删除旧的表
                .Tables(1).Select
                .Tables(1).Delete
            End If
            .PasteSpecial DataType:=1, Placement:=0            '9
            '.PasteAndFormat (0) '默认粘贴
        End With
    Else
        xlapp.ActiveDocument.Selection = "*** 没有找到 ***"
    End If
    On Error GoTo 0
End Sub