有个愚蠢的问题困扰好久，因为要团队内要编辑大量的月报和项目信息，又要去要脱敏，无非是涉及到项目内容的省市县名称都得替换成某省某市某县。

这样一来，简单的事情复杂化，复杂的东西人工化。这几天抽空，借助AI调整了一番，2分钟内可顺利实现，相比也有很多非研发人员也会遇到这种情况，分享给诸位，节省生命。

原理就是根据标准的行政区划，然后检索文档/表格，将对应行政区划名称统一替换成“某”，同理，如果要替换敏感词，下载个敏感词库即可。

当然对于程序员可能还有更便捷的方法，这里是面向零开发基础人员。

行政区划文件下载：行政区划表格

Step1：Excel/word 打开Visual Basic编辑器

A：按住Alt+F11键；
B：是从“开发工具”选项卡打开。

在VBA编辑器中，添加或创建新模块，然后直接粘代码，该文件的对应地址和shhet名称。

Step:2：修改VB代码中的表格源

1.Excel 批量脱敏替换省市县名称为“某”

Sub ReplaceValuesFromAnotherSheet()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim cell As Range, rngSearch As Range
    Dim searchValue As Variant
      
    ' 设置源工作表和目标工作表
    Set wsSource = ThisWorkbook.Sheets("Sheet3") ' 假设源数据在Sheet3
    Set wsTarget = ThisWorkbook.Sheets("Sheet2") ' 假设要替换数据在Sheet2
      
    ' 定义搜索范围，这里以Sheet2的A1:Z100为例
    Set rngSearch = wsTarget.Range("A1:C446")
      
    ' 遍历源工作表的每一个单元格
    For Each cell In wsSource.UsedRange
        ' 假设源工作表中的数据在A列，你可以根据需要修改
        searchValue = cell.Value
          
        ' 在目标工作表中搜索匹配项并替换
        With rngSearch
            .Replace What:=searchValue, Replacement:="某", LookAt:=xlPart, MatchCase:=False
        End With
    Next cell
      
    MsgBox "替换完成！"
End Sub

2.Word 批量脱敏替换省市县名称为“某”

Sub ReplacePlaceNames()
    ' 声明变量
    Dim wb As Object
    Dim ws As Object
    Dim row As Long
    Dim col As Integer
    Dim oldName As String
    Dim newName As String
    
    ' 初始化Excel应用程序
    Dim excelApp As Object
    Set excelApp = CreateObject("Excel.Application")
    excelApp.Visible = False ' 设置Excel不可见
    
    ' 加载Excel工作簿 替换标准区划文件地址
    Set wb = excelApp.Workbooks.Open("C:\Users\xx\2023-03-17最新行政区划.xlsx")
    
    ' 通过名称获取工作表
    Set ws = wb.Sheets("2023-03-17行政区划") ' 假设所有数据都在名为“2023-03-17行政区划”的工作表上
    
    ' 创建一个集合来存储所有需要替换的名称
    Dim namesToReplace As Collection
    Set namesToReplace = New Collection
    
    ' 遍历Excel中的每一行
    For row = 1 To 3635 ' 直接使用已知的行数
        ' 遍历每一行中的每一列 (假设为四列)
        For col = 1 To 4
            oldName = Trim(ws.Cells(row, col).Value)
            If oldName <> "" Then
                ' 检查集合中是否已经存在该名称
                Dim exists As Boolean
                exists = False
                For Each existingItem In namesToReplace
                    If existingItem = oldName Then
                        exists = True
                        Exit For
                    End If
                Next existingItem
                
                ' 如果不存在，则添加到集合中
                If Not exists Then
                    namesToReplace.Add oldName, oldName
                End If
            End If
        Next col
    Next row
    
    ' 替换Word文档中的旧名称为新名称
    Dim item As Variant
    For Each item In namesToReplace
        newName = "某"
        With ActiveDocument
            .Content.Find.Execute FindText:=item, MatchCase:=False, Forward:=True, Wrap:=wdFindStop, ReplaceWith:=newName, Replace:=wdReplaceAll
        End With
    Next item
    
    ' 清理
    wb.Close False ' 不保存更改
    excelApp.Quit
    Set wb = Nothing
    Set ws = Nothing
    Set excelApp = Nothing
    MsgBox "替换完成！"
End Sub