VBA code to change date in workbook links-CodePudding

In a workbook I have links to another workbook from which it gathers some info. The link contains month number (09,10,11..); month name (Sep,Oct,Nov) and year. I am trying to make a VBA code which would change the dates in the external link to the present values. After it updates link. In case of an error (it couldn't find files using the link) code takes previous dates and loops until the link is working. For example, now it Oct 10 2021, but the code can't find the file it should take Sep 9 2021 and if this link didn't work it takes Aug 8 2021 and etc. Another problem is local of the date. I have to take en-US local for the month name, but I couldn't manage to do this.

I have a code below which is an attempt to do these operations. Thank you for your help in advance!

Sub changeLinks()
Dim link, linkSources, newLink As String
Dim today As Date
Dim monthname As Date
Dim monthnumber As Date
Dim yr As Date

today = Now()
'monthname = Format(Now(), "[$-en-US]MMM;@")
monthnumber = Format(today, "mm")
yr = Format(Now(), "yyyy")

newLink = "https:linklinklink" _
          & yr & "/" & monthnumber & "_" & monthname & "/Report" & monthnumber & ".xlsx"
linkSources = ThisWorkbook.linkSources(xlLinkTypeExcelLinks)
If IsArray(linkSources) Then
    For Each link In linkSources
        'If InStr(link, "test1.xls") Then _'
        ThisWorkbook.ChangeLink link, newLink, xlLinkTypeExcelLinks
    Next
End If
On Error GoTo pvDate
    ThisWorkbook.UpdateLink Name:=ThisWorkbook.linkSources
Exit Sub

pvDate:
    monthname = WorksheetFunction.EDate(Format(Now(), "[$-en-US]mmm;@"), 1)
    monthnumber = WorksheetFunction.EDate(Format(Now(), "mm"), 1)
    yr = WorksheetFunction.EDate(Format(Now(), "yyyy"), 1)
    newLink = "https:linklinklink" _
          & yr & "/" & monthnumber & "_" & monthname & "/Report" & monthnumber & ".xlsx"
    linkSources = ThisWorkbook.linkSources(xlLinkTypeExcelLinks)
    If IsArray(linkSources) Then
        For Each link In linkSources
        'If InStr(link, "test1.xls") Then _'
            ThisWorkbook.ChangeLink link, newLink, xlLinkTypeExcelLinks
        Next
    End If
    ThisWorkbook.UpdateLink Name:=ThisWorkbook.linkSources
    
End Sub

CodePudding user response：

This repeatedly checks if the newlink file can be opened before either giving up or, if successful, proceeding to update the links. I assume you want the month names to be independent of the locale so I have put them in an array.

Option Explicit

Sub changeLinks()

    Const URI = "https:linklinklink"
    Const MAX_TRY = 5

    Dim mthname
    mthname = Array("", "Jan", "Feb", "Mar", "Apr", "May", "Jun", _
                       "Jul", "Aug", "Sep", "Oct", "Nov", "Dec")

    Dim links, link, newlink As String, msg As String
    Dim wb As Workbook, wblink As Workbook

    Set wb = ThisWorkbook
    links = wb.LinkSources(xlLinkTypeExcelLinks)
    If Not IsArray(links) Then
        MsgBox "No links to update", vbCritical
        Exit Sub
    End If

    ' determine latest link
    Dim dt As Date, n As Long, m As Integer, bOK As Boolean
    dt = Date
    Do While Not bOK
        m = Month(dt)
        newlink = URI & Format(dt, "yyyy/m_") & mthname(m) & "/Report" & m & ".xlsx"
        msg = msg & vbCrLf & newlink
        On Error Resume Next
        Set wblink = Workbooks.Open(newlink, 0, 1)
        If wblink Is Nothing Then
            ' previous month
            dt = DateAdd("m", -1, dt)
        Else
            wblink.Close False
            bOK = True
        End If
        On Error GoTo 0
        ' limit attempts
        n = n   1
        If n > MAX_TRY Then
            MsgBox MAX_TRY & " attempts, giving up " & msg, vbExclamation
            Exit Sub
        End If
    Loop

    ' update links
    If bOK Then
        n = 0
        For Each link In LinkSources
            wb.ChangeLink link, newlink, xlLinkTypeExcelLinks
            n = n   1
        Next
        wb.UpdateLink Name:=wb.LinkSources
        MsgBox n & " links updated to " & newlink, vbInformation
    End If

End Sub