| |
一応出来上がったので・・・。
ＰＣ８０台 ユーザーは実質 約１３０名ほど
リンクの変更が自分でできる人 一割居るかいないか位の職場です。
成功率８０％目標、後は個別対応
option Explicit
'ネットワークドライブ検査
’各ユーザーで割り当てが違ってる場合が多いので調査
Sub Net_D調査()
Dim Wsh_N As Object
Dim oDrives As Object
Dim i As Long
Set Wsh_N = CreateObject("WScript.Network")
Set oDrives = Wsh_N.EnumNetworkDrives
With ThisWorkbook.Sheets("Net_D書出し")
.Range("C2:D65530").ClearContents
For i = 0 To oDrives.Count - 2 Step 2
With .Range("C65530").End(xlUp).Offset(1)
If oDrives.Item(i) <> "" Then
.Value = oDrives.Item(i)
Else
.Value = "???" '何かわからん
End If
.Offset(, 1).Value = oDrives.Item(i + 1)
End With
Next i
End With
Set oDrives = Nothing
Set Wsh_N = Nothing
End Sub
'変換リストからネットワークドライブに割り当てられているドライブと変換先
'を追加していく
'Sheet2.Range("A2:B6")は変換リスト
'A列 B列
'現状 新リンク
'ｴﾝｴﾝF-sv03ｴﾝA ｴﾝｴﾝppｴﾝdfsｴﾝA第1部
'ｴﾝｴﾝF-sv03ｴﾝB ｴﾝｴﾝppｴﾝdfsｴﾝA第2部
Sub 変換リスト作成()
Dim f_R As Range
Dim S_r As Range
Dim Hit_R As Range
Dim HIT_RR As Range
With ThisWorkbook.Sheets("Net_D書出し")
.Range("A7:B65535").ClearContents
'接続先検索range設定（Sub Net_D調査で作成したリスト）
Set S_r = .Range("D2:D" & .Range("D65535").End(xlUp).Row)
'現状range設定（）
Set Hit_R = .Range("A2:A" & .Range("A65535").End(xlUp).Row)
'接続先が新リンク先に当てはまるか？当てはまればリストに追加
For Each f_R In S_r
For Each HIT_RR In Hit_R
If LCase(f_R.Value) = LCase(HIT_RR.Value) Then '大文字小文字が違うかも・・・なので
.Range("A65535").End(xlUp).Offset(1).Value = f_R.Offset(, -1).Value
.Range("B65535").End(xlUp).Offset(1).Value = HIT_RR.Offset(, 1).Value
Exit For
End If
Next
Next
End With
End Sub
'これでThisWorkbook.Sheets("Net_D書出し")のＡ列は
'ネットワークドライブの割り当てを含め置換したいリスト
'Ｂ列に置換するリストが出来上がった。
'ここから、実際にリンクの設定をしなおす
Sub リンク変更()
Dim Find_R As Range '置換対象のリスト
Dim Tar_B As Workbook
Dim aLinks As Variant
Dim Hit_R As Range
Dim i As Long
Dim V_Path As Variant
With ThisWorkbook.Sheets("Net_D書出し")
Set Find_R = .Range("A2:A" & .Range("A65536").End(xlUp).Row)
End With
Set Tar_B = ActiveWorkbook
aLinks = Tar_B.LinkSources
If Not IsEmpty(aLinks) Then
For i = 1 To UBound(aLinks)
With ThisWorkbook.Sheets("変換履歴").Range("A65536").End(xlUp).Offset(1)
.Value = i
V_Path = Split(aLinks(i), "\")
If V_Path(0) <> "" Then 'ネットワークドライブ割り当ての場合
.Offset(, 1).Value = V_Path(0)
Else '\\***\*** なので、０と１は ""
.Offset(, 1).Value = "\\" & V_Path(2) & "\" & V_Path(3)
End If
Set Hit_R = Find_R.Find(What:=.Offset(, 1).Value, LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not Hit_R Is Nothing Then '実際はChangeLink メソッドで変更が
.Offset(, 2).Value = Replace(aLinks(i), .Offset(, 1).Value, Hit_R.Offset(, 1).Value)
End If
V_Path = ""
End With
Next i
Else
MsgBox "対象のリンクはありません"
End If
end sub
いろんな方々のコードをパクリました。
ご指導いただければうれしいです。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 12/2/21(火) 10:15 -
