如何避免Excel单元格内图片因Value2赋值操作被覆盖？

问题根源 #

你执行cell.Value2 = cell.Value2的操作会破坏绑定在单元格中的图片——这类单元格的内容并非常规文本/数值，而是关联了图片对象，读取Value2会触发类型不匹配错误，强制赋值会直接切断图片与单元格的关联，导致图片消失并显示#VALUE。

方案一：通过错误捕获跳过带图片的单元格 #

利用VBA的错误捕获机制，识别出无法读取Value2的带图片单元格，跳过赋值操作，同时保留图片关联：

Sub CleanUpPreservePics()
    Dim ws As Worksheet
    Dim cell As Range
    
    For Each ws In ThisWorkbook.Worksheets
        ' 清理所有ActiveX控件
        ws.OLEObjects.Delete
        
        ' 遍历已用区域，跳过带图片的单元格
        For Each cell In ws.UsedRange
            On Error Resume Next
            Dim tempVal As Variant
            tempVal = cell.Value2
            ' 无错误则执行赋值（公式转值），有错误则跳过
            If Err.Number = 0 Then
                cell.Value2 = tempVal
            End If
            On Error GoTo 0
        Next cell
    Next ws
End Sub

说明 #

• 先执行ws.OLEObjects.Delete直接移除ActiveX控件，满足清理需求。
• 用On Error Resume Next捕获读取Value2时的类型不匹配错误，一旦报错就跳过该单元格的赋值，避免破坏图片关联。

方案二：精准识别图片所在单元格范围 #

先遍历工作表所有图片，记录其覆盖的单元格地址，处理时跳过这些范围，更精准地保护图片：

Sub CleanUpPreservePicsPrecise()
    Dim ws As Worksheet
    Dim cell As Range
    Dim picRanges As Collection
    Dim shp As Shape
    Dim addr As String
    
    Set picRanges = New Collection
    
    For Each ws In ThisWorkbook.Worksheets
        ' 记录所有图片覆盖的单元格范围
        For Each shp In ws.Shapes
            If shp.Type = msoPicture Then
                addr = shp.TopLeftCell.Address & ":" & shp.BottomRightCell.Address
                ' 用集合去重，避免重复记录同一范围
                On Error Resume Next
                picRanges.Add addr, Key:=addr
                On Error GoTo 0
            End If
        Next shp
        
        ' 清理ActiveX控件
        ws.OLEObjects.Delete
        
        ' 处理公式转值，跳过图片所在单元格
        For Each cell In ws.UsedRange
            Dim isPicCell As Boolean
            isPicCell = False
            For Each addr In picRanges
                If Not Intersect(cell, ws.Range(addr)) Is Nothing Then
                    isPicCell = True
                    Exit For
                End If
            Next addr
            If Not isPicCell Then
                cell.Value2 = cell.Value2
            End If
        Next cell
        
        ' 重置集合，处理下一张工作表
        Set picRanges = New Collection
    Next ws
End Sub

说明 #

• 先通过shp.Type = msoPicture筛选出图片类型的Shape，记录其覆盖的单元格范围。
• 处理单元格时，检查当前单元格是否属于图片覆盖范围，是则跳过赋值，确保图片的位置、大小和关联完全保留，依然支持快速放大查看后放回原位置。

内容的提问来源于stack exchange，提问作者xvpnkr