Excelのリンク移行方法とは？

質問

• Ｍドライブに入っている基礎データをＧドライブにリンクさせている場合、ＭドライブがＨドライブに移行することになった場合、ＧドライブのExcelファイルのリンク元もＭドライブからＨドライブに変更する必要があります。対象のExcelファイルを1つ1つ開いて置換で変更する方法もありますが、作業量が多くなるため、もっと簡単な方法があれば知りたいです。
• Excelファイルのリンク移行についてお聞きします。現在、Ｍドライブに保存されている基礎データをＧドライブにリンクさせていますが、ＭドライブがＨドライブに移行することになりました。この場合、ＧドライブのExcelファイルのリンク元もＭドライブからＨドライブに変更する必要があります。手作業で1つずつ変更する方法もありますが、もっと効率的な方法を教えていただけないでしょうか？
• Ｍドライブに保存されている基礎データをＧドライブにリンクさせていますが、ＭドライブがＨドライブに移行することになりました。そのため、ＧドライブのExcelファイルのリンク元も変更する必要があります。1つずつ変更する方法もありますが、手間がかかるため、もっと簡単な方法を知りたいです。お知恵をお貸しいただけませんか？

回答No.3

KenKen_SP · ベストアンサー

再度こんにちは、KenKen_SP です。

指定フォルダ内のExcelファイルにおいて、一括置換を行うコードです。
検索語や置換語はディフォルトで使えるようにしてありますが、指定
することもできます。

すみませんが、かなり即効でつくったので、動作確認が不十分です。
試す場合は必ずバックアップを取ってからお試し下さい。無保証です。

シートが保護されていたりすると置換に失敗しますので、その際はエラー
ログを出力する仕様にはしましたが、手抜きですので、こちらの処理で
エラーがでるかも。余り大量のファイルを一度に処理しない方がいいと
思います。

標準モジュールに貼り付けて下さい。

余談ですが、数式によるリンク部の置換を対象としていますが、コード
を一箇所直すと値の一括置換ができます。この場合、REPLACE_EX 関数の
第4引数を False にするだけです。

Option Explicit

'// フォルダ内の複数のブックで置換処理
Sub REPLACE_MANY_BOOKS()

　　'※Thisworkbookは対象外となります

　　Dim WB　As Workbook
　　Dim SH　As Worksheet
　　Dim FSO As Object
　　Dim objFOLDER　As Object
　　Dim strERRLOG　As String
　　Dim sBEFORE　　As String
　　Dim sAFTER　　 As String
　　Dim sERRMES　　As String
　　Dim lngCNT　　 As Long
　　Dim strLOGPATH As String
　　Dim strDIR　　 As String
　　Dim strPATH　　As String

　　'検索語指定
　　sBEFORE = InputBox(Prompt:="検索語を入力して下さい", Default:="M:\")
　　If sBEFORE = "" Then Exit Sub
　　'置換語指定
　　sAFTER = InputBox(Prompt:="置換語を入力して下さい", Default:="H:\")
　　If sAFTER = "" Then Exit Sub
　　'フォルダ選択ダイアログ表示
　　Set objFOLDER = CreateObject("Shell.Application"). _
　　　　BrowseForFolder(0, "フォルダを選択してください", 0, vbNullString)
　　If Not objFOLDER Is Nothing Then
　　　　strDIR = objFOLDER.Self.Path
　　　　Set objFOLDER = Nothing
　　Else
　　　　Exit Sub
　　End If
　　'エラーログの場所
　　strLOGPATH = strDIR & "\ERRORLOG.txt"
　　'警告処理
　　lngCNT = MsgBox( _
　　　　　　　　Prompt:="このマクロは一括置換を行い自動で上書きします。" & vbCrLf _
　　　　　　　　　　& "必ずバックアップを取ってから実行して下さい。" _
　　　　　　　　　　& vbCrLf & vbCrLf _
　　　　　　　　　　& "処理対象：" & strDIR & vbCrLf _
　　　　　　　　　　& "処理内容：" & sBEFORE & " --> " & sAFTER, _
　　　　　　　　Buttons:=vbOKCancel + vbDefaultButton2 + vbExclamation, _
　　　　　　　　Title:="実行許可")
　　If lngCNT = vbCancel Then Exit Sub

　　'初期化
　　lngCNT = 0
　　strERRLOG = "/// 以下のファイルで置換に失敗しました ///" & vbCrLf _
　　　　　　　　& vbCrLf & "・フォルダー:=" & strDIR _
　　　　　　　　& vbCrLf & "・検索する語:=" & sBEFORE _
　　　　　　　　& vbCrLf & "・置換する語:=" & sAFTER & vbCrLf & vbCrLf

　　'ファイル検索＆置換処理
　　On Error GoTo TERMINATE
　　With Application
　　　　.ScreenUpdating = False
　　　　.StatusBar = True
　　　　.Cursor = xlWait
　　End With
　　strPATH = Dir(strDIR & "\*.xls") '<------------検索ファイル指定
　　If strPATH = "" Then Exit Sub
　　Do
　　　　strPATH = strDIR & Application.PathSeparator & strPATH
　　　　If strPATH <> ThisWorkbook.FullName Then
　　　　　　Set WB = Workbooks.Open(strPATH)
　　　　　　Application.StatusBar = "TARGET:=" & WB.Name
　　　　　　DoEvents
　　　　　　For Each SH In WB.Worksheets
　　　　　　　　'※REPLACE_EX関数のオプション第4引数にTrueを指定すると
　　　　　　　　'※数式の置換になる
　　　　　　　　If Not REPLACE_EX(SH, sBEFORE, sAFTER, sERRMES, True) Then
　　　　　　　　　　strERRLOG = strERRLOG _
　　　　　　　　　　　　& "---------------------------------------------------------------" _
　　　　　　　　　　　　& vbCrLf & "◆" & WB.Name & "[ " & SH.Name & "]" _
　　　　　　　　　　　　& vbCrLf & "※" & sERRMES & vbCrLf
　　　　　　　　　　lngCNT = lngCNT + 1
　　　　　　　　End If
　　　　　　Next SH
　　　　　　WB.Close SaveChanges:=True
　　　　End If
　　　　strPATH = Dir()
　　Loop Until strPATH = ""
　　Set WB = Nothing

　　'終了処理
　　If lngCNT = 0 Then
　　　　MsgBox "正常終了しました", vbInformation
　　Else
　　　　'ロギング
　　　　MsgBox lngCNT & "件のシートで置換に失敗しました。" & _
　　　　　　　　"エラーログを出力します。", vbExclamation
　　　　Set FSO = CreateObject("Scripting.FileSystemObject")
　　　　With FSO.CreateTextFile(strLOGPATH, True)
　　　　　　.WriteLine (strERRLOG)
　　　　　　.Close
　　　　End With
　　　　Set FSO = Nothing
　　　　'エラーログ表示
　　　　Shell "notepad.exe " & Chr(34) & strLOGPATH & Chr(34), vbNormalFocus
　　End If

TERMINATE:
　　With Application
　　　　.Cursor = xlDefault
　　　　.StatusBar = ""
　　End With

End Sub

'// 置換処理関数
Public Function REPLACE_EX( _
　　ByRef SH As Worksheet, _
　　ByRef sBEFORE As String, _
　　ByRef sAFTER As String, _
　　ByRef sERRMES As String, _
　　Optional ByVal FORMULA_ONLY As Boolean = False) As Boolean

　　Dim rngTARGET As Range

　　On Error GoTo ERROR_HANDLER
　　If FORMULA_ONLY Then
　　　　'SpecialCellsValues Class
　　　　'(xlErrors OR xlLogical OR xlNumbers OR xlTextValues)=23
　　　　Set rngTARGET = SH.Cells.SpecialCells(xlCellTypeFormulas, 23)
　　Else
　　　　Set rngTARGET = SH.UsedRange
　　End If
　　rngTARGET.Replace _
　　　　　　What:=sBEFORE, _
　　　　　　Replacement:=sAFTER, _
　　　　　　LookAt:=xlPart, _
　　　　　　MatchCase:=False
　　REPLACE_EX = True
　　sERRMES = ""
　　Exit Function

ERROR_HANDLER:
　　REPLACE_EX = False
　　sERRMES = Err.Description & vbCrLf
　　Err.Clear

End Function

お礼

ありがとうございます。

すっごい・・・
ところどころしか意味がわかりませんが
早速月曜日に行ってみます。

取り急ぎ御礼を・・・と思いまして・・・＾＾

結果をまた補足させていただきます。

補足

早速使用してみました。

きちんとできました。

わかりやすいように説明もしていただき
ありがとうございました。