VBA代码更改工作簿链接中的日期

Question

在一个工作簿中，我有指向另一个工作簿的链接，它从中收集一些信息。该链接包含月份编号（09,10,11..）；月份名称（Sep、Oct、Nov）和年份。我正在尝试制作一个 VBA 代码，它将外部链接中的日期更改为当前值。更新链接后。如果出现错误（使用链接找不到文件），代码会获取以前的日期并循环，直到链接正常工作。例如，现在是 2021 年 10 月 10 日，但代码找不到应该在 2021 年 9 月 9 日使用的文件，如果此链接不起作用，则需要 2021 年 8 月 8 日等。另一个问题是本地日期。我必须以 en-US local 作为月份名称，但我无法做到这一点。

我在下面有一个代码，尝试执行这些操作。提前感谢您的帮助！

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

Answer 1

这会反复检查是否可以在放弃之前打开新链接文件，如果成功，则继续更新链接。我假设您希望月份名称独立于语言环境，因此我将它们放在一个数组中。

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