利用vba替换word中多个表格，相邻单元格的文字

目录

• 一、效果图
• • 1、替换前
  • 2、替换后
• 二、敲代码
• • 1、开发者工具→vba编辑器，点击插入模块
  • 2、键入以下代码
  • 3、代码编辑完成后，开发者工具→运行宏，选择对应名称，运行

一、效果图

标题估计没说明白，上图

1、替换前

2、替换后

如下图目标达成

二、敲代码

1、开发者工具→vba编辑器，点击插入模块

2、键入以下代码

Sub ReplaceTenConsecutiveCells()
    Dim tbl As Table, targetCells As Range
    Dim oldGroups() As Variant, newGroups() As Variant
    Dim i As Long, j As Long, k As Long, m As Long
    
    ' ====== 配置区 ======
    ' 定义旧值组合 vs 新值组合（必须一一对应）
    oldGroups = Array(Array("A1", "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9", "A10"), Array("B1", "B2", "B3", "", "", "", "", "", "", ""))
    newGroups = Array( _
        Array("New1", "New2", "New3", "New4", "New5", "New6", "New7", "New8", "New9", "New10"), _
        Array("替换1", "替换2", "替换3", "", "", "", "", "", "", "") _
    )
    'Const HIGHLIGHT_COLOR As Long = RGB(0, 176, 80) ' 标记颜色（绿色）
    ' ====== 配置结束 ======
    
    Application.ScreenUpdating = False
    For Each tbl In ActiveDocument.Tables
        For i = 1 To tbl.Rows.Count
            ' 动态计算可用列范围
            For j = 1 To tbl.Columns.Count - 9 ' 确保有连续10列
                ' 提取连续10单元格内容（清理结尾符）
                Dim currentGroup(9) As String
                For k = 0 To 9
                    On Error Resume Next ' 跳过合并单元格错误
                    currentGroup(k) = Replace(tbl.cell(i, j + k).Range.Text, Chr(13) & Chr(7), "")
                    On Error GoTo 0
                Next k
                
                ' 遍历所有预设规则进行匹配
                For k = 0 To UBound(oldGroups)
                    Dim isMatch As Boolean
                    isMatch = True
                    For m = 0 To 9
                        ' 空字符串表示跳过该位置匹配
                        If oldGroups(k)(m) <> "" And currentGroup(m) <> oldGroups(k)(m) Then
                            isMatch = False
                            Exit For
                        End If
                    Next m
                    
                    ' 执行替换并标记
                    If isMatch Then
                        For m = 0 To 9
                            On Error Resume Next ' 跳过合并单元格写入
                            tbl.cell(i, j + m).Range.Text = newGroups(k)(m)
                            tbl.cell(i, j + m).Shading.BackgroundPatternColor = RGB(0, 176, 80)
                            On Error GoTo 0
                        Next m
                        Exit For ' 匹配成功即跳出循环
                    End If
                Next k
            Next j
        Next i
    Next tbl
    Application.ScreenUpdating = True
    MsgBox "已处理 " & UBound(oldGroups) + 1 & " 组规则，替换完成！"
End Sub

一些说明

3、代码编辑完成后，开发者工具→运行宏，选择对应名称，运行