[[20070213141159]]　『ハイパーリンクのリンク先のフォルダを一括置換し』（ちぃ）　ページの最後に飛ぶ

『ハイパーリンクのリンク先のフォルダを一括置換したい』（ちぃ）

Excel2003(XP) です。
ハイパーリンクのリンク先に、pdfファイルを設定しています。

例えば、以下のように、リンク先のフォルダを変更した場合、

　変更前　　　　　　　　　　　　変更後

　　リンク先←フォルダ名　　　　　　リンク先←フォルダ名

　　　　|　　　　　　　　　　　　　　　　　　　|

      |- 1.pdf                        -2006
      |- 2.pdf                       |   |
       - 3.pdf                       |    -1.pdf
         :                           |    -2.pdf
                                      -2007
                                         |
                                          -3.pdf
                                            :

この場合、セルを1つずつ「ハイパーリンクの編集」で
フォルダを新しいフォルダに変更していかなければいけないでしょうか？

ハイパーリンクされた全てのセルを一括置換できないでしょうか？

なお、マクロ・関数はものすごい凝った物でないならわかります。
すみませんが、まことによろしくお願いします。

 Sub TEST20070213_3()
     Rem ハイパーリンクの変更
     Dim hlLink As Hyperlink
     Dim strFname1 As String, strFname2 As String
     Dim lngAns As Long
     For Each hlLink In ActiveSheet.Cells.Hyperlinks
         Do
         hlLink.Range.Select
         strFname1 = hlLink.Address
         strFname2 = Application.GetOpenFilename("PDFファイル (*.pdf),*.pdf", , strFname1)
         lngAns = MsgBox(strFname1 & Chr(10) & Chr(10) & _
                         "へのリンクを" & Chr(10) & Chr(10) & _
                         strFname2 & Chr(10) & Chr(10) & _
                        "に置き換えます。" & Chr(10) & "よろしいですか？" & Chr(10) & Chr(10) & _
                        "はい：置き換え" & Chr(10) & Chr(10) & _
                        "いいえ：次のリンクへ" & Chr(10) & Chr(10) & _
                        "キャンセル：ファイル選択に戻る", vbYesNoCancel)
         Loop While lngAns = vbCancel
         If lngAns = vbYes Then hlLink.Address = strFname2
     Next hlLink
 End Sub
　
あまり労力に差がないかも（汗）
(みやほりん)(-_∂)b

ありがとうございます。

参考になりました。m(._.)m

書いてくださったマクロを参考に
いろいろやってみましたが、あまり労力に差がないかもしれません。

しかし、単純なフォルダ名の変更・追加であるならば
マクロが楽そうです。

ありがとうございました。

みやほりんさんのコメントを参考に作ってみました。
質問したちぃです。

Sub ハイパーリンク先のフォルダを変更()

    Dim hlink As Hyperlink
    Dim FileName As String
    For Each hlink In ActiveSheet.Hyperlinks
          hlink.Range.Select
          With hlink
            hadd = .Address
          End With
          Sentaku = MsgBox(hadd & Chr(10) & Chr(10) & _
                      "へのハイパーリンクを置き換えますか？" & Chr(10) & Chr(10) & _
                                        Chr(10) & Chr(10) & _
                      "　はい：置き換えるためファイルを選ぶ" & Chr(10) & Chr(10) & _
                      "　いいえ：次のリンクへ" & Chr(10) & Chr(10) & _
                      "　キャンセル：中止", vbYesNoCancel + vbDefaultButton1 + vbQuestion, "ハイパーリンクの変更")
          If Sentaku = vbCancel Then Exit Sub
          If Sentaku = vbNo Then GoTo A
            FileName = Application.GetOpenFilename("PDF ファイル(*.pdf),*.pdf")
              If FileName = "False" Then Exit Sub
            lngAns = MsgBox(hadd & Chr(10) & Chr(10) & _
                         "　へのハイパーリンクを" & Chr(10) & Chr(10) & _
                          FileName & Chr(10) & Chr(10) & _
                         "　に置き換えます。　よろしいですか？" & Chr(10) & Chr(10) & Chr(10) & _
                         "　はい：置き換え" & Chr(10) & Chr(10) & _
                         "　いいえ：次のリンクへ" & Chr(10) & Chr(10) & _
                         "　キャンセル：中止", vbYesNoCancel + vbDefaultButton1 + vbExclamation, "ハイパーリンクの変更")
            If lngAns = vbYes Then hlink.Address = FileName
            If lngAns = vbCancel Then Exit Sub
A:
    Next hlink
 End Sub

 がんばってますね。
 If Sentaku = vbNo Then GoTo A　～　A:　は
 If Sentaku = vbYes Then 　～　End If　でもよいかもしれません。
　
もう一つサンプルを作ってみました。
　
 Sub TEST20070214()
     Rem ファイルリスト作成
     Const myPath = "C:\temp"
     Dim myFsys As Object, myFld As Object, mySF As Object, _
         myFiles As Object, objfls As Object, objsfld As Object
     Dim i As Long
     i = 1
         Set myFsys = CreateObject("Scripting.FileSystemObject")
         Set myFld = myFsys.GetFolder(myPath)
         Set myFiles = myFld.Files
         For Each objfls In myFiles
             Cells(i, 1).Value = objsfld.Path & "\" & objfls.Name
             i = i + 1
         Next objfls
         Set mySF = myFld.SubFolders
         For Each objsfld In mySF
            Set myFiles = objsfld.Files
            For Each objfls In myFiles
                Cells(i, 1).Value = objsfld.Path & "\" & objfls.Name
                i = i + 1
            Next
         Next objsfld
     Set myFiles = Nothing
     Set mySF = Nothing
     Set myFld = Nothing
     Set myFsys = Nothing
 End Sub
　
C:\tempというフォルダ、及びその直下のサブフォルダ（一階層）の
ファイルリストを作成します。作成したリストを元にHYPERLINK関数で
ハイパーリンクを作成するのも良いかもしれません。
(みやほりん)(-_∂)b

ありがとうございます。

＞If Sentaku = vbYes Then 　～　End If　でもよいかもしれません。

お～その手がありましたね。

ということで改定第2弾ですが、まだ GoTo が取れません。
GoTo を無くすにはどうしたらいいか、お分かりでしょうか？

Sub ハイパーリンク先を変更()

    Dim hlink As Hyperlink
    Dim FileName As String
    For Each hlink In ActiveSheet.Hyperlinks
          hlink.Range.Select
          With hlink
            hadd = .Address
          End With
A:
          Sentaku = MsgBox(hadd & Chr(10) & Chr(10) & _
                      "へのハイパーリンクを置き換えますか？" & Chr(10) & Chr(10) & _
                                        Chr(10) & Chr(10) & _
                      "　はい：置き換えるためファイルを選ぶ" & Chr(10) & Chr(10) & _
                      "　いいえ：次のリンクへ" & Chr(10) & Chr(10) & _
                      "　キャンセル：中止", vbYesNoCancel + vbDefaultButton1 + vbQuestion, "ハイパーリンクの変更")
          If Sentaku = vbCancel Then Exit Sub
          If Sentaku = vbYes Then
              FileName = Application.GetOpenFilename("PDF ファイル(*.pdf),*.pdf")
                If FileName = "False" Then GoTo A
              lngAns = MsgBox(hadd & Chr(10) & Chr(10) & _
                         "　へのハイパーリンクを" & Chr(10) & Chr(10) & _
                         FileName & Chr(10) & Chr(10) & _
                         "　に置き換えます。　よろしいですか？" & Chr(10) & Chr(10) & Chr(10) & _
                         "　はい：置き換え" & Chr(10) & Chr(10) & _
                         "　いいえ：次のリンクへ" & Chr(10) & Chr(10) & _
                         "　キャンセル：中止", vbYesNoCancel + vbDefaultButton1 + vbExclamation, "ハイパーリンクの変更")
              If lngAns = vbCancel Then Exit Sub
              If lngAns = vbYes Then
                  hlink.Address = FileName
                  hlink.Range.Font.Bold = True
              End If
          End If
    Next hlink
 End Sub

 ちぃさん、ごめんなさい、すっかり見落としてしまったようです。
もうしわけありません。ずいぶん間が空いてしまいましたので見てくれていると良いのですが。
　
 Sub ハイパーリンク先を変更() 
    Dim hlink As Hyperlink
    Dim FileName As String
    For Each hlink In ActiveSheet.Hyperlinks
          hlink.Range.Select
          With hlink
            hadd = .Address
          End With
      Do
          Sentaku = MsgBox("" & Chr(10) & Chr(10) & _
                      "へのハイパーリンクを置き換えますか？" & Chr(10) & Chr(10) & _
                                        Chr(10) & Chr(10) & _
                      "　はい：置き換えるためファイルを選ぶ" & Chr(10) & Chr(10) & _
                      "　いいえ：次のリンクへ" & Chr(10) & Chr(10) & _
                      "　キャンセル：中止", vbYesNoCancel + vbDefaultButton1 + vbQuestion, "ハイパーリンクの変更")
          If Sentaku = vbCancel Then Exit Sub
          FileName = Application.GetOpenFilename("PDF ファイル(*.pdf),*.pdf")
      Loop While FileName = "False"
      If Sentaku = vbYes Then
              lngAns = MsgBox(hadd & Chr(10) & Chr(10) & _
                         "　へのハイパーリンクを" & Chr(10) & Chr(10) & _
                         FileName & Chr(10) & Chr(10) & _
                         "　に置き換えます。　よろしいですか？" & Chr(10) & Chr(10) & Chr(10) & _
                         "　はい：置き換え" & Chr(10) & Chr(10) & _
                         "　いいえ：次のリンクへ" & Chr(10) & Chr(10) & _
                         "　キャンセル：中止", vbYesNoCancel + vbDefaultButton1 + vbExclamation, "ハイパーリンクの変更")
              If lngAns = vbCancel Then Exit Sub
              If lngAns = vbYes Then
                  hlink.Address = FileName
                  hlink.Range.Font.Bold = True
              End If
          End If
    Next hlink
 End Sub
　
(みやほりん)(-_∂)b

ありがとうございます。見てますよ～(^^)/

コメントを参考にした後、
さらに、
　1.If Sentaku = vbNo の行を付け加え、
　2.もともと太字になっているのならそのセルはスキップする
ようにしました。

つまり、結局、以下のようなマクロで落ち着きました。

Sub ハイパーリンク先を変更()

    Dim hlink As Hyperlink
    Dim FileName As String
    For Each hlink In ActiveSheet.Hyperlinks
        If hlink.Range.Font.Bold = False Then    '05行目
          hlink.Range.Select
          With hlink
            hadd = .Address
          End With
          Do
            Sentaku = MsgBox(hadd & Chr(10) & Chr(10) & _
                      "へのハイパーリンクを置き換えますか？" & Chr(10) & Chr(10) & _
                                        Chr(10) & Chr(10) & _
                      "　はい：置き換えるためファイルを選ぶ" & Chr(10) & Chr(10) & _
                      "　いいえ：次のリンクへ" & Chr(10) & Chr(10) & _
                      "　キャンセル：中止", vbYesNoCancel + vbDefaultButton1 + vbQuestion, "ハイパーリンクの変更")
            If Sentaku = vbCancel Then Exit Sub
            If Sentaku = vbNo Then Exit Do
            FileName = Application.GetOpenFilename("PDF ファイル(*.pdf),*.pdf")
          Loop While FileName = "False"
            If Sentaku = vbYes Then              '21行目
              lngAns = MsgBox(hadd & Chr(10) & Chr(10) & _
                       "　へのハイパーリンクを" & Chr(10) & Chr(10) & _
                       FileName & Chr(10) & Chr(10) & _
                       "　に置き換えます。　よろしいですか？" & Chr(10) & Chr(10) & Chr(10) & _
                       "　はい：置き換え" & Chr(10) & Chr(10) & _
                       "　いいえ：次のリンクへ" & Chr(10) & Chr(10) & _
                       "　キャンセル：中止", vbYesNoCancel + vbDefaultButton1 + vbExclamation, "ハイパーリンクの変更")
              If lngAns = vbCancel Then Exit Sub
              If lngAns = vbYes Then             '30行目
                  hlink.Address = FileName
                  hlink.Range.Font.Bold = True
              End If  '30行目を受ける
            End If    '21行目を受ける
        End If        '05行目を受ける
    Next hlink
 End Sub

です。これにより、数多くのセルにハイパーリンクが設定されていて、
リンクを貼られたファイルが存在するフォルダを変えてしまった場合、
効率よく、リンク先のフォルダを変更していくことが出来るようになりました。

ありがとうございました。（ちぃ）

コメント返信：

[ 一覧(最新更新順) ]

[[20070213141159]] 『ハイパーリンクのリンク先のフォルダを一括置換し』（ちぃ） ページの最後に飛ぶ

[[20070213141159]]　『ハイパーリンクのリンク先のフォルダを一括置換し』（ちぃ）　ページの最後に飛ぶ