请大神帮忙修改下代码

改成图片自动居中的，谢谢！

Sub Autoaddpic()
For Each Shp In ActiveSheet.Shapes
If Shp.Type = msoPicture Then Shp.Delete
Next
Dim MyPcName As String
For i = 1 To ThisWorkbook.ActiveSheet.UsedRange.Rows.Count
If (ActiveSheet.Cells(i, 4).Value = "图片") Then
MyPcName = ActiveSheet.Cells(i, 3).Value & ".jpg"
ActiveSheet.Cells(i, 4).Select
Dim MyFile As Object
Set MyFile = CreateObject("Scripting.FileSystemObject")
If MyFile.FileExists(ThisWorkbook.Path & "\" & "pic" & "\" & MyPcName) = False Then
MsgBox ThisWorkbook.Path & "\" & "pic" & "\" & MyPcName & "暂无图片"
Else
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & "pic" & "\" & MyPcName).Select
End If
End If
Next i

End Sub

呵呵，我不是什么大神。
要居中，主要是加了对图片操作的代码，也就是下面的with语句，修改后的代码如下：

Sub Autoaddpic()
On Error Resume Next '这句好像意义不大
Application.ScreenUpdating = False
Dim MyPcName$, MyMsg$, MyPic$ '加多一个Mypic变量，直观一点；加了Mymsg变量，变成一次过汇总输出缺少的图片提示
Dim MyFile As Object
Set MyFile = CreateObject("Scripting.FileSystemObject")
For Each Shp In ActiveSheet.Shapes
If Shp.Type = msoPicture Then Shp.Delete
Next
For i = 1 To ThisWorkbook.ActiveSheet.UsedRange.Rows.Count
If ActiveSheet.Cells(i, 4).Value = "图片" Then
MyPcName = ActiveSheet.Cells(i, 3).Value & ".jpg"
MyPic = ThisWorkbook.Path & "\" & "pic" & "\" & MyPcName
If MyFile.FileExists(MyPic) = False Then
MyMsg = MyMsg & vbCrLf & MyPic & " 暂无图片"
Else
ActiveSheet.Pictures.Insert(MyPic).Select '当前文件所在目录下以单元内容为名称的.jpg图片
With Selection
ta = Range(Cells(i, 4).MergeArea.Address).Height '(合并)单元高度
tb = Range(Cells(i, 4).MergeArea.Address).Width '(合并)单元宽度
tc = .Height*.99 '图片高度
td = .Width '图片宽度
tm = Application.WorksheetFunction.Min(ta / tc, tb / td) '单元与图片之间长宽差异比例的最小值
.Height = .Height * tm * 0.95 '按比例调整图片宽度，*.95为缩小一点
.Width = .Width * tm * 0.95 '按比例调整图片高度，*.95为缩小一点
.Top = Cells(i, 4).Top + (Cells(i, 4).MergeArea.Height - .Height) / 2 '垂直居中:
.Left = Cells(i, 4).MergeArea.Left + (Cells(i, 4).MergeArea.Width - .Width) / 2 '水平居中:
End With
ActiveCell.Select '获得焦点
End If
End If
Next
If Len(MyMsg) <> 0 Then
MsgBox MyMsg
End If
Set MyFile = Nothing
Application.ScreenUpdating = True
End Sub

如以上回答内容为低俗、色情、不良、暴力、侵权、涉及违法等信息，可以点下面链接进行举报！

点此我要举报以上问答信息