Chuyển thư mục có chứa File Hyperlink sang ổ đĩa khác

[tadolieu]

Chào mọi người, mọi người cứu vớt e với
Em có 1 thư mục chứa nhiều file Excel, bản vẽ và hình ảnh, các file Excel link với nhau và link đến hình ảnh, bản vẽ
Khi em chuyển NGUYÊN thư mục này qua ổ đĩa khác, thì các đường link nó tự chuyển đổi qua ổ đĩa mới nên vẫn link được, riêng phần link hình ảnh nó vẫn giữ nguyên định dạng link theo ổ đĩa cũ nên không mở được, dù cách làm giống nhau
Ai biết nguyên nhân và cách khắc phục cho e xin với, e cảm ơn!

 

[Hoàng Tuấn 868]

riêng phần link hình ảnh nó vẫn giữ nguyên định dạng link theo ổ đĩa cũ nên không mở được,
Ai biết nguyên nhân và cách khắc phục cho e xin với, e cảm ơn!

Phần bôi đậm là nguyên nhân, cách khắc phục thì chưa nghĩ ra.

 

[tadolieu]

Phần bôi đậm là nguyên nhân, cách khắc phục thì chưa nghĩ ra.

Cùng 1 cách làm như nhau ạ, các thư mục khác của mình cũng link hình ảnh nhưng khi chuyển ổ đĩa vẫn hoạt động bình thường
Có thư mục bị lỗi là mình lấy từ máy khác qua

 

[HeSanbi]

Link như thế nào bạn có thể chụp 1 vài hình ảnh không

 

[tadolieu]

Mình gửi ảnh ạ, khi m chuyển qua ổ đĩa E, các phần link file Excel khác, hoặc file bản vẽ đều tự chuyển ổ đĩa E khi di chuyển qua ổ đĩa mới, riêng link mở hình ảnh vẫn giữ link ổ đĩa cũ là D

 

[HeSanbi]

Dùng mã dưới đây để bạn sửa tệp của bạn. Hãy chép mã vào một Module của tệp.
Nhập đường dẫn cũ và đường dẫn mới vào hai ô, giữ Ctrl chọn 2 ô đó và bạn chạy mã với nút hoặc nhấn F5.
Ví dụ: A1 nhập D:\folder\
A3 nhập E:\folder\

Lưu ý tạo bản sao lưu để an toàn.

Option Compare Text
Option Explicit

Sub HyperLinkChange()
  On Error Resume Next
  Dim FSO As Object, sh, addr1, addr2, s$, k&, c&
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Dim h As Hyperlink
  addr1 = Selection.areas(1)(1, 1).value
  addr2 = Selection.areas(2)(1, 1).value
  For Each sh In ThisWorkbook.Worksheets
    For Each h In sh.Hyperlinks
      If h.Address Like "[CDEFGHIJKLMNOPQRSTWXYZ]:\*" Then
        c = c + 1
        If Not FSO.fileExists(h.Address) Then
          s = Replace$(h.Address, addr1, addr2)
          If FSO.fileExists(s) And s <> h.Address Then
            h.Address = s: k = k + 1
          End If
        End If
      End If
    Next
  Next
  MsgBox "Ða sua: " & k & "/" & c & " Address"
End Sub

 

[tadolieu]

Dùng mã dưới đây để bạn sửa tệp của bạn. Hãy chép mã vào một Module của tệp.
Nhập đường dẫn cũ và đường dẫn mới vào hai ô, giữ Ctrl chọn 2 ô đó và bạn chạy mã với nút hoặc nhấn F5.
Ví dụ: A1 nhập D:\folder\
A3 nhập E:\folder\

Lưu ý tạo bản sao lưu để an toàn.

Option Compare Text
Option Explicit

Sub HyperLinkChange()
  On Error Resume Next
  Dim FSO As Object, sh, addr1, addr2, s$, k&, c&
  Set FSO = CreateObject("Scripting.FileSystemObject")
  Dim h As Hyperlink
  addr1 = Selection.areas(1)(1, 1).value
  addr2 = Selection.areas(2)(1, 1).value
  For Each sh In ThisWorkbook.Worksheets
    For Each h In sh.Hyperlinks
      If h.Address Like "[CDEFGHIJKLMNOPQRSTWXYZ]:\*" Then
        c = c + 1
        If Not FSO.fileExists(h.Address) Then
          s = Replace$(h.Address, addr1, addr2)
          If FSO.fileExists(s) And s <> h.Address Then
            h.Address = s: k = k + 1
          End If
        End If
      End If
    Next
  Next
  MsgBox "Ða sua: " & k & "/" & c & " Address"
End Sub

Cảm ơn ạ, mình sẽ thử xem sao