Sub MacroFind()
Dim FindRng As Range, TxtFind As String, FirstAdr As String, RngDel As Range, StrokaAdr As String
    TxtFind = "D:\*"
    Set FindRng = Range("B1:Q20").Cells.Find(What:=TxtFind, LookIn:=xlFormulas, LookAt:=xlPart)
    If Not FindRng Is Nothing Then
        FirstAdr = FindRng.Address
        Do
            If StrokaAdr = "" Then
                StrokaAdr = FindRng.Address
            Else
                StrokaAdr = StrokaAdr & "," & FindRng.Address
            End If
            Set FindRng = Cells.FindNext(FindRng)
        Loop While FindRng.Address <> FirstAdr
    Else
        MsgBox "Значение [" & TxtFind & "] не найдено!", 48, "Ошибка"
        Exit Sub
    End If
    Range(StrokaAdr).Select
End Sub

Public Sub LinkDocs()
   'Установление связей рабочей книги
   Dim BookLinks As Variant
   Dim i As Integer
   With ThisWorkbook
      ' связи с другими книгами Excel.
      BookLinks = .LinkSources(xlExcelLinks)
      If Not IsEmpty(BookLinks) Then
         MsgBox "Существуют ссылки на рабочие книги Excel!", 26, "Ссылки"
         For i = LBound(BookLinks) To UBound(BookLinks)
            [COLOR=#0000FF]MsgBox "Ссылка" & i & " : ", BookLinks(i), 48, "Ссылки"[/COLOR]
                If BookLinks(i) = "BookTwo" Then
               .OpenLinks BookLinks(i)
               .ChangeLink BookLinks(i), "BookOne"
            End If
         Next i
      Else: MsgBox "Ссылки на рабочие книги отсутствуют!", 48, "Ошибка"
      End If
   End With
End Sub

Sub Мяу()
    Dim aLinks, txt$, FirstAdr$, StrokaAdr$, FindRng As Range, aft As Range, i&
    aLinks = ActiveWorkbook.LinkSources(xlExcelLinks)
    If Not IsEmpty(aLinks) Then
        Set aft = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell)
        For i = 1 To UBound(aLinks)
            If Dir(aLinks(i)) = "" Then
                txt = Left$(aLinks(i), InStrRev(aLinks(i), "\")) & "[" & Mid$(aLinks(i), InStrRev(aLinks(i), "\") + 1)
                Set FindRng = ActiveSheet.UsedRange.Cells.Find(What:=txt, After:=aft, LookIn:=xlFormulas, LookAt:=xlPart)
                If Not FindRng Is Nothing Then
                    FirstAdr = FindRng.Address(0, 0)
                    Do
                        If StrokaAdr = "" Then
                            StrokaAdr = FindRng.Address(0, 0)
                        Else
                            If Len(StrokaAdr) > 230 Then
                                Range(StrokaAdr).Interior.ColorIndex = i + 2
                                StrokaAdr = FindRng.Address(0, 0)
                            Else
                                StrokaAdr = StrokaAdr & "," & FindRng.Address(0, 0)
                            End If
                        End If
                        Set FindRng = Cells.FindNext(FindRng)
                        DoEvents
                    Loop While FindRng.Address(0, 0) <> FirstAdr
                End If
                Range(StrokaAdr).Interior.ColorIndex = i + 2
            End If
        Next i
    End If
End Sub