Sub ПоискСвязей()
     Dim Sht As Worksheet
     Dim rng As Range, cell As Range
     Dim msg$, FirstAddress$

     On Error Resume Next
     For Each Sht In ActiveWorkbook.Worksheets

         Set rng = Sht.Range("A1").SpecialCells(xlCellTypeFormulas)
         Set cell = rng.Find(What:="[", _
                             LookIn:=xlFormulas, _
                             LookAt:=xlPart, _
                             SearchDirection:=xlNext)

         If Not cell Is Nothing Then
             FirstAddress = cell.Address
             Do
                 msg = msg & Sht.Name & vbTab & cell.Address(False, False) & vbNewLine
                 Set cell = rng.FindNext(cell)
             Loop While Not cell Is Nothing And cell.Address <> FirstAddress
         End If

         Set cell = Nothing
         Set rng = Nothing
     Next Sht
     MsgBox msg
End Sub