Цитата |
---|
Микки написал: Наверное список на другом листе (Связи) влияющая связанная...чаще всего это только одна |
Для меня непозволительно долго разрабатывать парсинг, т.к. опыта в этом деле практически ноль. Потому отчёт простой: имя листа, адрес ячейки, формула.
Скрытый текст |
---|
Код |
---|
Sub jjj_find_external_links()
Dim sFormula As String, sStr As String, tfHasIndirect As Boolean, rngTargetCells As Range, cl As Range, _
arrResult(), arrTransp(), lCnt As Long, lR As Long, lC As Long, lRn As Long, lCn As Long, _
wshNew As Worksheet
On Error Resume Next
Set rngTargetCells = ActiveSheet.Cells.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If rngTargetCells Is Nothing Then Exit Sub
lCnt = 1
ReDim arrResult(1 To 2, 1 To lCnt)
arrResult(1, lCnt) = rngTargetCells.Parent.Name
For Each cl In rngTargetCells
tfHasIndirect = False
sStr = ""
If cl.HasFormula Then
sFormula = cl.Formula
With CreateObject("VBScript.RegExp")
.Global = True
.IgnoreCase = True
.Pattern = """.*?"""
sStr = .Replace(sFormula, "")
.Pattern = "INDIRECT\(.*?"".*?!.*?"".*?\)"
tfHasIndirect = .Test(sFormula)
End With
End If
If sStr Like "*!*" Or tfHasIndirect Then
lCnt = lCnt + 1
ReDim Preserve arrResult(1 To 2, 1 To lCnt)
arrResult(1, lCnt) = cl.Address
arrResult(2, lCnt) = cl.FormulaLocal
End If
Next cl
If lCnt > 1 Then
lRn = UBound(arrResult, 2)
lCn = UBound(arrResult, 1)
ReDim arrTransp(1 To lRn, 1 To lCn)
For lR = 1 To lRn
For lC = 1 To lCn
arrTransp(lR, lC) = arrResult(lC, lR)
Next lC
Next lR
Erase arrResult
Set wshNew = rngTargetCells.Parent.Parent.Sheets.Add(After:=rngTargetCells.Parent, Count:=1, Type:=xlWorksheet)
With wshNew.Cells(1, 1).Resize(lRn, lCn)
.NumberFormat = "@"
.Value = arrTransp
End With
Erase arrTransp
End If
End Sub
|
|