Changing link source via VBA

[tdevrieze]

I'm having major issues and no one in my office seems to be able to help. I've searched this site as well as google extensivly and have found no answers.

I have two worksheets (sheets 1&3) within one workbook, each worksheet is linked to a different file. Normally I'd go to "edit links" and update the source manually for both worksheets, this is no longer a viable solution and needs to be automated. Both worksheets are protected with the same password.

I've got it so it'll unlock both worksheets, however instead of only updating the worksheet i've selected it updates both worksheets with the same information.

I'm exteremly green when it comes to VBA so any help will need to be dumbed down, the following has been pieced together from the internet and a programmer here who quite frankly hasnt been all that helpful.

This is exteremely time sensitive so any help or insight would be greatly appreciated. I'm stuck.

Thanks.

Sub MyChangeLinkSource()
Dim varFileName As Variant
Dim arrLinks As Variant
Dim ws As Worksheet
Dim msg As String
Dim I As Long
'Object references
Set ws = ActiveSheet

'Check for links
arrLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
If IsEmpty(arrLinks) Then
msg = "This workbook does not contain any links!"
MsgBox msg
Exit Sub
End If
'Unprotect worksheet
For I = 1 To Sheets.Count
If I = 1 Or I = 3 Then
Sheets(I).Select
ActiveSheet.Unprotect Password:="HEYNOW123"
End If
Next I
'Get new source file
varFileName = Application.GetOpenFilename(Title:="Select a File to Import")
On Error Resume Next
If varFileName = "False" Then End
On Error GoTo 0
'Error handler to re-protect workbook in case of errors
On Error GoTo Handler
'Change link source
arrLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
ActiveWorkbook.ChangeLink arrLinks(1), varFileName, xlExcelLinks
'Re-protect and exit sub
MyExitSub:
For I = 1 To Sheets.Count
If I = 1 Or I = 3 Then
Sheets(I).Select
ActiveSheet.Protect Password:="HEYNOW123"
End If
Next I
Exit Sub
'Handle errors
Handler:
msg = "Error " & Err.Number & vbCrLf & Err.Description
msg = msg & vbCrLf & vbCrLf & "Please see Todd Devrieze for assistance."
MsgBox msg
Resume MyExitSub
End Sub

 

[tdevrieze]

I should also note that there will be a button to run the macro by the end user on each individual worksheet, so if the code above is horrible, I'm more than open to using two individual macros (one for each sheet) if that is easier.<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
<o></o>
Again, thanks and any help is greatly appreciated.<o></o>

 

[tdevrieze]

Really? Not one idea, eh?

 

[AlphaFrog]

Sub MyChangeLinkSource()

    Dim varFileName As Variant
    Dim arrLinks    As Variant
    Dim ws          As Worksheet
    Dim MyLink      As String
    Dim I           As Long

    'Object references
    Set ws = ActiveSheet

    'Check for links
    arrLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
    If IsEmpty(arrLinks) Then
        MsgBox "This workbook does not contain any links!", vbOKOnly, "No External Links"
        Exit Sub
    End If

    'Get new source file
    varFileName = Application.GetOpenFilename(Title:="Select a File to Import")
    If varFileName = "False" Then Exit Sub
    
    'Error handler to re-protect workbook in case of errors
    On Error GoTo Handler
x = 1 / 0
    ' Add braces [] around file name
    MyLink = Mid(varFileName, InStrRev(varFileName, "\") + 1)
    varFileName = Replace(varFileName, MyLink, "[" & MyLink & "]")

    'Change link source
    arrLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
    
    'Unprotect worksheet
    ws.Unprotect Password:="HEYNOW123"

    For I = 1 To UBound(arrLinks)
        ' Add braces [] around each link filename
        MyLink = Mid(arrLinks(I), InStrRev(arrLinks(I), "\") + 1)
        MyLink = Replace(arrLinks(I), MyLink, "[" & MyLink & "]")
        
        ' Replace old LinkSources file name with new
        If Not ws.Cells.Find(MyLink, , xlFormulas) Is Nothing Then
            ws.Cells.Replace What:=MyLink, Replacement:=varFileName, LookAt:=xlPart
        End If
        
    Next I

    'Handle errors
Handler:
    If Err.Number <> 0 Then
        MsgBox "Error " & Err.Number & vbCrLf & Err.Description & _
                vbLf & vbLf & "Please see Todd Devrieze for assistance."
    End If
    
    'Re-protect and exit sub
    ws.Protect Password:="HEYNOW123"

End Sub

 

[tdevrieze]

Thank you!

 

[erdow]

Really? Not one idea, eh?

tdevrieze i try to use your code but i get error 11, can you help me please?