采取超链接，然后使用超链接引用从源复制到目的地

“好吧，所以修改了提供的脚本，它不再跳过计数的超链接，现在带来了正确数量的文件，但它是由于某种原因复制PDF文件。我已经validation，每个超链接是唯一的，源文件名地点是彼此独特的。

下面的例子是我testing过的一个列表。 本来我的脚本只会在列表中引入第一个pdf。 现在使用更新后的脚本查看所有实例，但复制第一个PDF。

来源看它。

..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HL.pdf ..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HL-I.pdf ..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HM.pdf ..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HM-I.pdf ..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HS.pdf ..\..\..\..\Cutsheets\Delta\Software\01 - Controller - Delta - DOW-340-HS-I.pdf 

什么它在文件夹中粘贴。 它使用相同的pdf，并将行号添加到开始。 就像它没有读过HL中超链接的字符一样。

 01 - Controller - Delta - DOW-340-HL.pdf 36-01 - Controller - Delta - DOW-340-HL.pdf 37-01 - Controller - Delta - DOW-340-HL.pdf 38-01 - Controller - Delta - DOW-340-HL.pdf 39-01 - Controller - Delta - DOW-340-HL.pdf 40-01 - Controller - Delta - DOW-340-HL.pdf Public Sub CopyFile2() Dim rng As Range Const strNewDir As String = "D:\test\" For Each rng In Range("L9:L1017").SpecialCells(xlCellTypeVisible) If CBool(rng.Hyperlinks.Count) Then With rng.Hyperlinks(1) If CBool(InStr(.Address, Chr(92))) Then If Dir(strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92)))) = "" Then FileCopy .Address, _ strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92))) Else FileCopy .Address, _ strNewDir & rng.Row & "-" & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92))) End If Else If Dir(strNewDir & .Address) = "" Then FileCopy .Address, _ strNewDir & .Address Else FileCopy .Address, _ strNewDir & rng.Row & "-" & .Address End If End If End With End If Next rng End Sub 

Answer 1

我假设你想继续使用Application.Selection属性。

 Public Sub CopyFile() Dim rng As Range Const strNewDir As String = "D:\test\" For Each rng In Selection.SpecialCells(xlCellTypeVisible) If CBool(rng.Hyperlinks.Count) Then With rng.Hyperlinks(1) If CBool(InStr(.Address, Chr(92))) Then FileCopy .Address, _ strNewDir & Replace(.Address, Chr(92), vbNullString, InStrRev(.Address, Chr(92))) Else FileCopy .Address, _ strNewDir & .Address End If End With End If Next rng End Sub