VBA - Checke cellereference

Denne kode checker om en reference er fra en ekstern fil:

Function ErKaede(ck)
    Dim a As Integer
    FrstTegn = InStr(1, ck.Formula, "[")
    If ck.HasFormula Then
        If FrstTegn > 0 Then
            ErKaede = True
        Else
            ErKaede = False
        End If
    End If
End Function

Denne returnerer kæden

Function VisKaede(ck)
    VisKaede = Mid(ck.Formula, 2, Len(ck.Formula))
End Function

denne makro finder cellereferencer til filer, der ikke eksisterer.
Hvis den finder en ikke eksisterende filreference, oprettes en cellekommentar med den manglede reference



Sub FindDeadLinksInActiveSheet()

Dim rngCell As Range
Dim x As Variant
Dim st As String
Dim OldText As String
Dim NewText As String
Dim i As Long

    For Each rngCell In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 21).Cells
        x = MissingLink(rngCell.Formula)
        If UBound(x) > 0 Then
            st = ""
            With rngCell
                On Error Resume Next
                OldText = .Comment.Text
                If Err <> 0 Then .AddComment
                For i = 0 To UBound(x)
                    If st = "" Then st = x(i) Else st = st & vbLf & x(i)
                Next
                NewText = st
                .Comment.Text NewText
                .Comment.Visible = True
                .Comment.Shape.Select
                Selection.AutoSize = True
            End With
        End If
    Next
   
End Sub


Private Function MissingLink(MyString As String) As Variant
    Dim RegEx As Object
    Dim Temp As String
    Dim varTemp As Variant
    Dim FileExist As Boolean
    Dim x As Long
    Dim Itm As Object
    Dim FID As Object
   
    Set RegEx = CreateObject("vbscript.regexp")

    RegEx.Global = True
    RegEx.Pattern = "'[^*][^']*'"
    Set FID = RegEx.Execute(MyString)
    If FID.Count > 0 Then
        ReDim varTemp(1 To FID.Count)
        For Each Itm In FID
            Temp = Replace(Itm, "[", "")
            Temp = Mid(Temp, 2, InStr(1, Temp, "]") - 2)
            FileExist = Len(Dir(Temp)) > 1
            If Not FileExist Then
                x = x + 1
                varTemp(x) = Temp
            End If
        Next
        ReDim Preserve varTemp(1 To x)
        MissingLink = varTemp
    Else
        MissingLink = Nothing
    End If
    Set RegEx = Nothing
End Function

Det var nu pænt af dig bak, men den del med hvad der skal ske finder jeg selv ud af. Jeg ved jo hvor potent du er til Excel, så måske kan du svare på denne: http://www.eksperten.dk/spm/820323

der er lige nogle rettelser til den (desværre)

Sub FindDeadLinksInActiveSheet()

    Dim rngCell As Range
    Dim varLinks As Variant
    Dim strTotal As String
    Dim strOldComment As String
    Dim strNewComment As String
    Dim l As Long

    For Each rngCell In ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas, 21).Cells
        varLinks = MissingLink(rngCell.Formula)
        If UBound(varLinks) > 0 And varLinks(1) <> 0 Then
            strTotal = ""
            With rngCell
                On Error Resume Next
                strOldComment = .Comment.Text
                If Err <> 0 Then .AddComment
                For l = 0 To UBound(varLinks)
                    If strTotal = "" Then strTotal = varLinks(l) Else strTotal = strTotal & vbLf & varLinks(l)
                Next
                strNewComment = strTotal
                .Comment.Text strNewComment
                .Comment.Visible = True
                .Comment.Shape.Select
                Selection.AutoSize = True
            End With
        End If
    Next

End Sub


Private Function MissingLink(MyString As String) As Variant
    Dim RegEx As Object
    Dim strTemp As String
    Dim varTemp As Variant
    Dim blnFileExist As Boolean
    Dim lngX As Long
    Dim objItem As Object
    Dim objFID As Object

    Set RegEx = CreateObject("vbscript.regexp")

    RegEx.Global = True
    RegEx.Pattern = "'[^*][^']*'"
    Set objFID = RegEx.Execute(MyString)

    If objFID.Count > 0 Then
        ReDim varTemp(1 To objFID.Count)
        For Each objItem In objFID
            strTemp = Replace(objItem, "[", "")
            strTemp = Mid(strTemp, 2, InStr(1, strTemp, "]") - 2)
            blnFileExist = Len(Dir(strTemp)) > 1
            If Not blnFileExist Then
                lngX = lngX + 1
                varTemp(lngX) = strTemp
            End If
        Next
    End If
    If lngX > 0 Then
        ReDim Preserve varTemp(1 To lngX)
        MissingLink = varTemp
    Else
        MissingLink = varTemp
    End If


    Set RegEx = Nothing
End Function

Jeg får desværre ikke tid til at teste foreløbig, men smid begge et svar.

Her er et svar.

bak?