插入PDF对象及Hyperlink问题

kangkumbong

请教各位老师：为什么FOR循环有重复数据的无法插入PDF对象及Hyperlink呢？比如第7行开始
还有若添加Hyperlink或清除可否保留单元格格式？
每次都得WITH FONT修改一次
PDF文件容量过大，只放了一个PDF文件，可修改文件名多创建几个PDF文件测试
谢谢

Sub 批量插入PDF对象()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim fn As String
Dim Obj As Object
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
    If sh.Type <> 8 Then
       sh.Delete
    End If
Next sh
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
  If fd.Show = -1 Then
      Path = fd.SelectedItems(1) & "\"
  Else
      MsgBox "未选择文件夹，程序结束"
      Exit Sub
  End If
Dim Str1 As String
Dim FileName As String
FileName = Dir(Path & "*.pdf")
Dim i As Long, IRow As Long
IRow = Range("C1048576").End(xlUp).Row
Do While FileName <> ""
  For i = 2 To IRow
    Str1 = Cells(i, 2).Value
    If InStr(FileName, Str1) And Str1 <> "" Then
      Cells(i, "D").Select '插入PDF对象单元格
      fn = FileName
      ActiveSheet.Hyperlinks.Add Cells(i, "C"), Path & fn, , fn
      ActiveSheet.OLEObjects.Add FileName:=Path & fn, link:=False, DisplayAsIcon:=True, IconFileName:= _
      "C:\Windows\Installer\{AC76BA86-1033-FFFF-7760-BC15014EA700}\_SC_Acrobat.ico", iconindex:=0, _
      iconlabel:=Replace(fn, ".pdf", "" & " Double-Click Icon") 'Replace删除PDF文件扩展名
    Exit For
    End If
  Next
  FileName = Dir '用dir函数取得其他文件名，并赋给变量
Loop
For Each sh In ActiveSheet.Shapes '所有图形对象
    If sh.Type <> 4 And sh.Type <> 8 Then
    If sh.LockAspectRatio = True Then
       With sh
            sh.LockAspectRatio = False '让图片的高度、宽度都允许修改（不锁定长宽比）
            sh.Left = sh.TopLeftCell.Left + 3 '调整左边距
            sh.Top = sh.TopLeftCell.Top + 3 '调整上边距
            sh.Width = sh.TopLeftCell.Width - 5 '调整宽度
            sh.Height = sh.TopLeftCell.Height - 5 '调整高度
            sh.Placement = xlMoveAndSize '图片随单元格移动
       End With
    End If
    End If
Next sh
Range("C1").End(xlDown).Rows.Select
  With Rows("2:" & ActiveCell.Row).Font
    .Name = "Arial"
    .Size = 14
    .Bold = False
  End With
ActiveCell.Select
MsgBox "PDF对象插入完毕"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

kangkumbong

终于找出问题了 朵儿一个代码 EXIT ROR作怪 谢谢！！