插入PDF对象及Hyperlink问题
请教各位老师：为什么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
呵呵
终于找出问题了 多了一个代码 EXIT ROR作怪 谢谢！！
页:
[1]