当然可以实现！完全不用改动你现有的数字驱动核心，咱们可以通过图片与单元格绑定+移动同步的方式来搞定，优先满足你想要的「图片跟随对应数字移动」的需求，下面给你两种可行方案：

方案一：图片随数字单元格自动移动（优先推荐） #

这个方案会让图片和单元格绑定，不管是通过VBA代码移动数字，还是手动修改单元格值，图片都会自动跟着数字的位置走，适配性更强。

步骤1：准备棋子图片 #

先给每种类型+颜色的棋子准备对应图片，命名要规范方便VBA调用，比如：

• 红兵：Red_Bing.png
• 绿兵：Green_Bing.png
• 红王：Red_Wang.png
• 绿王：Green_Wang.png
  以此类推，对应你给出的数字规则：1=兵、2=王、3=后、4=象、5=马、6=车。把所有图片存到一个固定路径，比如C:\ChessImages\。

步骤2：初始化图片绑定宏 #

运行这个宏可以一次性给所有有数字的单元格插入对应图片，并绑定到单元格位置：

Sub InitChessPieces()
    Dim ws As Worksheet
    Dim cell As Range
    Dim pic As Shape
    Dim picPath As String
    
    Set ws = ActiveSheet
    picPath = "C:\ChessImages\" '替换成你的实际图片存放路径
    
    '先清除已有棋子图片，避免重复创建
    For Each pic In ws.Shapes
        If Left(pic.Name, 5) = "Chess" Then pic.Delete
    Next pic
    
    '遍历所有有棋子数字的单元格，插入对应图片
    For Each cell In ws.UsedRange
        If cell.Value > 0 Then
            Dim picName As String
            '根据单元格字体颜色判断棋子阵营
            If cell.Font.Color = RGB(210, 0, 0) Then
                picName = "Red_" & GetPieceName(cell.Value)
            ElseIf cell.Font.Color = RGB(0, 175, 20) Then
                picName = "Green_" & GetPieceName(cell.Value)
            End If
            
            '插入图片并对齐到单元格
            Set pic = ws.Shapes.AddPicture( _
                picPath & picName & ".png", _
                LinkToFile:=False, _
                SaveWithDocument:=True, _
                Left:=cell.Left, Top:=cell.Top, _
                Width:=cell.Width, Height:=cell.Height _
            )
            '用单元格地址给图片命名，方便后续追踪
            pic.Name = "Chess_" & cell.Address(False, False)
            '设置图片不锁定，允许跟随单元格移动
            pic.Locked = False
        End If
    Next cell
End Sub

'辅助函数：根据数字返回棋子名称（对应图片命名）
Function GetPieceName(num As Integer) As String
    Select Case num
        Case 1: GetPieceName = "Bing"
        Case 2: GetPieceName = "Wang"
        Case 3: GetPieceName = "Hou"
        Case 4: GetPieceName = "Xiang"
        Case 5: GetPieceName = "Ma"
        Case 6: GetPieceName = "Che"
    End Select
End Function

步骤3：同步图片与数字移动 #

有两种方式实现同步，选其中一种即可：

方式A：在现有移动代码末尾添加同步逻辑

直接在你移动红色/绿色棋子的代码最后加上这段，精准同步当前移动操作：

'--- 红色棋子移动代码末尾添加 ---
Dim oldCellAddr As String, newCellAddr As String
oldCellAddr = Range("j2").Value
newCellAddr = Range("k2").Value

'找到原单元格绑定的图片，移到新单元格位置
On Error Resume Next '防止单元格无绑定图片的情况
Dim targetPic As Shape
Set targetPic = ActiveSheet.Shapes("Chess_" & Replace(oldCellAddr, "$", ""))
If Not targetPic Is Nothing Then
    With targetPic
        .Top = Range(newCellAddr).Top
        .Left = Range(newCellAddr).Left
        .Name = "Chess_" & Replace(newCellAddr, "$", "") '更新图片绑定的新单元格地址
    End With
End If
On Error GoTo 0

'--- 绿色棋子移动代码同理，只需要修改颜色判断，同步逻辑完全一致 ---

方式B：用工作表事件自动监听（更通用）

如果希望所有数字变动（包括手动修改）都能同步图片，右键工作表标签→查看代码，粘贴以下事件代码：

Private Sub Worksheet_Change(ByVal Target As Range)
    '只处理单个单元格的变动
    If Target.Cells.Count > 1 Then Exit Sub
    
    Dim pic As Shape
    Dim oldCell As Range
    
    '如果新单元格有棋子数字，检查是否有对应图片需要移动
    If Target.Value > 0 Then
        For Each pic In Me.Shapes
            If Left(pic.Name, 5) = "Chess" Then
                '获取图片绑定的旧单元格地址
                Set oldCell = Me.Range(Right(pic.Name, Len(pic.Name) - 5))
                '如果旧单元格现在值为0（说明棋子移走了），且颜色、类型匹配
                If oldCell.Value = 0 And _
                   ((oldCell.Font.Color = RGB(210, 0, 0) And Target.Font.Color = RGB(210, 0, 0)) Or _
                    (oldCell.Font.Color = RGB(0, 175, 20) And Target.Font.Color = RGB(0, 175, 20))) And _
                   GetPieceName(Target.Value) = Mid(pic.Name, 7, Len(pic.Name) - 6 - Len(Right(pic.Name, Len(pic.Name) - 5))) Then
                    '移动图片到新单元格
                    pic.Top = Target.Top
                    pic.Left = Target.Left
                    '更新图片绑定的新单元格地址
                    pic.Name = "Chess_" & Target.Address(False, False)
                    Exit For '找到对应图片后退出循环，提升效率
                End If
            End If
        Next pic
    End If
End Sub

记得把之前的GetPieceName函数也复制到这个模块里。

方案二：随VBA移动指令同步移动（备选） #

如果不想用事件监听，也可以直接在你的移动指令里硬编码图片移动逻辑，和数字操作强绑定，稳定性更高：

'--- 红色棋子移动代码修改版 ---
MoveNum = Range(Range("j2").Value).Value
Dim oldRange As Range, newRange As Range
Set oldRange = Range(Range("j2").Value)
Set newRange = Range(Range("k2").Value)

'原数字操作逻辑保持不变
oldRange.Value = 0
oldRange.FormulaR1C1 = ""
oldRange.Font.Color = -0
newRange.Value = MoveNum
newRange.Font.Color = RGB(210, 0, 0)

'同步图片移动
Dim targetPic As Shape
Set targetPic = ActiveSheet.Shapes("Chess_" & oldRange.Address(False, False))
If Not targetPic Is Nothing Then
    targetPic.Top = newRange.Top
    targetPic.Left = newRange.Left
    targetPic.Name = "Chess_" & newRange.Address(False, False)
End If

'--- 绿色棋子移动代码同理，修改颜色值即可 ---

注意事项 #

• 确保图片尺寸和单元格大小一致，这样对齐会更美观；
• 初始化宏只需要运行一次，或者可以加到Workbook_Open事件里，每次打开工作簿自动初始化；
• 如果图片路径有变动，记得修改picPath的值。

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