ハイパーリンクを参照して、ハイパーリンク参照を使用してソースからコピー先にコピー

Question

"Okこれで、提供されたスクリプトが変更され、ハイパーリンクをカウントしなくなり、何らかの理由でpdfsを複製しています。私は、各ハイパーリンクが一意であり、ソースの場所のファイル名が互いにユニークであることを確認しました。以下は、これをテストしたリストです。元のスクリプトはリストの最初の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