得得得,再发一次,系统再删我就爱莫能助了 VBA代码: Sub 图片匹配() Dim a As FileDialog Dim b As String Dim c As Range Dim d As Range Dim e As Range Dim f As String Dim g As String Dim h As String Dim i As Range Dim j As String '选择图片文件夹 Set a = Application.FileDialog(msoFileDialogFolderPicker) With a .Title = "请选择图片所在文件夹" If .Show <> -1 Then Exit Sub b = .SelectedItems(1) & "\" End With '选择名称区域 On Error Resume Next Set c = Application.InputBox("请选择名称所在区域(单列)", "选择名称区域", Type:=8) On Error GoTo 0 If c Is Nothing Then Exit Sub '选择图片放置区域 On Error Resume Next Set d = Application.InputBox("请选择图片放置区域(单列,与名称区域行数相同)", "选择图片区域", Type:=8) On Error GoTo 0 If d Is Nothing Then Exit Sub '检查区域是否匹配 If c.Rows.Count <> d.Rows.Count Then MsgBox "名称区域与图片区域行数不一致!", vbCritical Exit Sub End If '遍历名称区域并插入图片 Application.ScreenUpdating = False For Each e In c If e.Value <> "" Then '检查是否存在匹配的图片 j = Dir(b & e.Value & ".*") If j <> "" Then f = b & j Set i = d.Cells(e.Row - c.Row + 1, 1) ' 删除原有图片 On Error Resume Next i.Parent.Pictures("Pic_" & e.Value).Delete On Error GoTo 0 ' 插入图片并调整大小 With i.Parent.Pictures.Insert(f) .Name = "Pic_" & e.Value .ShapeRange.LockAspectRatio = msoFalse .Top = i.Top + 1 .Left = i.Left + 1 .Width = i.Width - 2 .Height = i.Height - 2 .Placement = xlMoveAndSize End With End If End If Next e Application.ScreenUpdating = True MsgBox "图片插入完成!", vbInformation End Su 执行程序按部就班操作即可