Başvuru yapılan hücrenin boyalı gözükmesi

[Ergun13]

Merhaba,
Ana Excel sayfamda yaptığım hesaplarda aynı excel dosyasındaki başka sayfaların bazı hücrelerine başvuru yapan formüller yer alıyor.
Bu ana sayfada bir başka sayfadaki başvuru yapılmış hücrelerin oldukları yerde hücrenin belirli bir renkte görülmesini nasıl sağlayabilirim ?

Örnek:
Sayfa1'de E5'teki hücre Sayfa2'de B1 hücresine başvuru yapan bir formüle sahip ise; Sayfa 2'deki B1 hücresinin renkli gözükmesini sağlayabilir miyim ?

 

[ÖmerFaruk]

Formüller Menüsü
Etkileyenleri İzle
seçeneğiyle görmek işinizi çözüyor mu?

 

[Ergun13]

Maalesef hayır. Başvuru yaptığım sayfadaki başvurulan hücreleri (ki bir kaç tane değil) ayrıca listelemeye ihtiyacım var.

 

[ÖmerFaruk]

Nette şöyle bir yazı var.
Buna göre farklı sayfalarda bunu bulumaıyoruz. En azından direkt sayfaya başvuru varsa Precedents özelliği çalışmıyor.
https://social.msdn.microsoft.com/Forums/office/en-US/6fc03fe8-6805-45db-a556-35ebb3c4f396/in-vba-how-to-get-all-precedents-of-a-formula-containing-external-structure-references-ie?forum=exceldev

Using VBA in either Excel 2007 or 2010, it appears Excel does not provide a means to determine ALL precedents of a cell. First, the Range.Precedents property only contains precedent cells that are on the same worksheet as the source cell (bummer). Second, using Range.ShowPrecedents with Range.NavigateArrow (or just doing the equivalent through the UI) does not work if the formula contains structure references that are on another worksheet. For example, if on Sheet1 I have to tables, TestTableOne, and TestTableTwo, and on Sheet2 in cell A1 I have the formula "=TestTableOne[Column1]+TestTableTwo[Column2]", and I then click "Trace Precedents" from the Formulas Ribbon tab, Excel throws the error "The Trace Precedents command requires that the active cell contain a formula which includes valid references"; they are valid references. Does anyone know, using just Excel VBA, how to get all Precedents for a cell in this situation?
Regards,
Paul

Yazıda 2010 için olmadığını söylese de daha yeni versiyon olarak Office 365 de ben denedim ve kod hata verdi

 

[uzmanamele]

Merhaba

Bunu deneyiniz, işinize yarayabilir.

Formüller / gözcü penceresi / gözcü ekle

 

[Ergun13]

Teşekkürler. Bunu denedim. Ama bu istediğimi tersten yapan bir şey
Ayrıca değişikliği takip etmek bu aşamada benim için gerekli değil

 

[Ergun13]

Nette şöyle bir yazı var.
Buna göre farklı sayfalarda bunu bulumaıyoruz. En azından direkt sayfaya başvuru varsa Precedents özelliği çalışmıyor.
https://social.msdn.microsoft.com/Forums/office/en-US/6fc03fe8-6805-45db-a556-35ebb3c4f396/in-vba-how-to-get-all-precedents-of-a-formula-containing-external-structure-references-ie?forum=exceldev

Using VBA in either Excel 2007 or 2010, it appears Excel does not provide a means to determine ALL precedents of a cell. First, the Range.Precedents property only contains precedent cells that are on the same worksheet as the source cell (bummer). Second, using Range.ShowPrecedents with Range.NavigateArrow (or just doing the equivalent through the UI) does not work if the formula contains structure references that are on another worksheet. For example, if on Sheet1 I have to tables, TestTableOne, and TestTableTwo, and on Sheet2 in cell A1 I have the formula "=TestTableOne[Column1]+TestTableTwo[Column2]", and I then click "Trace Precedents" from the Formulas Ribbon tab, Excel throws the error "The Trace Precedents command requires that the active cell contain a formula which includes valid references"; they are valid references. Does anyone know, using just Excel VBA, how to get all Precedents for a cell in this situation?
Regards,
Paul

Yazıda 2010 için olmadığını söylese de daha yeni versiyon olarak Office 365 de ben denedim ve kod hata verdi

Bu cevaplardan Peter Thornton'un akışı çalıştırılabilir mi ? Sanırım buna ihtiyacım var.

 

[ÖmerFaruk]

Mesela Sayfa1 A1 de
=B1+C1 formülü olsun
Range("A1").Precedents.Interior.ColorIndex = 4
Bu kod satırını bu sayfada çalıştırırsanız B1 ve C1 renklenir.

Eğer bu Sayfa1 A1 deki formül
=Sayfa2!B1+Sayfa2!C1
şeklinde olursa kod satırı çalışmaz. Dediği bu.

 

[Ergun13]

Evet. Maalesef çalışmayan kod satırı işimi gören şey

 

[mahmut011]

Merhaba,
Aşağıdaki linkte bulunan sayfada Test2 makrosuyla başlayan kod sayfa1 deki formülleri etkileyen diğer sayfalardaki hücrelerin adreslerini buluyor.

VBA: Determine All Precedent Cells – A Nice Example Of Recursion

I’ve been working on a project for this blog which I’ve found quite demanding. It’s taken me to parts of the Excel object model which I’ve never explored and challenged me t…

colinlegg.wordpress.com

Test2 makrosunda bulduğu hücrelerin arka planını boyaması için kodda değişiklik yaptım.
Dosyanızın yedeğini alarak deneyin.

Sub Test2()

    Dim rngToCheck As Range, s As Range
    Dim dicAllPrecedents As Object
    Dim i As Long
   

    Set rngToCheck = Sayfa1.UsedRange
    Set dicAllPrecedents = GetAllPrecedents(rngToCheck)

'    Debug.Print "==="

    If dicAllPrecedents.Count = 0 Then
'        Debug.Print rngToCheck.Address(External:=True); " has no precedent cells."
    Else
        For i = 1 To Worksheets.Count
            Worksheets(i).UsedRange.ClearFormats
     
        Next i
    For i = LBound(dicAllPrecedents.Keys) To UBound(dicAllPrecedents.Keys)
'            Debug.Print "[ Level:"; dicAllPrecedents.Items()(i); "]";
'            Debug.Print "[ Address: "; dicAllPrecedents.Keys()(i); " ]"

            Range(dicAllPrecedents.Keys()(i)).Interior.Color = rgbYellow
     
        Next i
    End If
'    Debug.Print "==="

End Sub

'won't navigate through precedents in closed workbooks
'won't navigate through precedents in protected worksheets
'won't identify precedents on hidden sheets
Public Function GetAllPrecedents(ByRef rngToCheck As Range) As Object

    Const lngTOP_LEVEL As Long = 1
    Dim dicAllPrecedents As Object
    Dim strKey As String

    Set dicAllPrecedents = CreateObject("Scripting.Dictionary")

    Application.ScreenUpdating = False

    GetPrecedents rngToCheck, dicAllPrecedents, lngTOP_LEVEL
    Set GetAllPrecedents = dicAllPrecedents

    Application.ScreenUpdating = True

End Function

Private Sub GetPrecedents(ByRef rngToCheck As Range, ByRef dicAllPrecedents As Object, ByVal lngLevel As Long)

    Dim rngCell As Range
    Dim rngFormulas As Range

    If Not rngToCheck.Worksheet.ProtectContents Then
        If rngToCheck.Cells.CountLarge > 1 Then   'Change to .Count in XL 2003 or earlier
            On Error Resume Next
            Set rngFormulas = rngToCheck.SpecialCells(xlCellTypeFormulas)
            On Error GoTo 0
        Else
            If rngToCheck.HasFormula Then Set rngFormulas = rngToCheck
        End If

        If Not rngFormulas Is Nothing Then
            For Each rngCell In rngFormulas.Cells
                GetCellPrecedents rngCell, dicAllPrecedents, lngLevel
            Next rngCell
            rngFormulas.Worksheet.ClearArrows
        End If
    End If

End Sub

Private Sub GetCellPrecedents(ByRef rngCell As Range, ByRef dicAllPrecedents As Object, ByVal lngLevel As Long)

    Dim lngArrow As Long
    Dim lngLink As Long
    Dim blnNewArrow As Boolean
    Dim strPrecedentAddress As String
    Dim rngPrecedentRange As Range

    Do
        lngArrow = lngArrow + 1
        blnNewArrow = True
        lngLink = 0

        Do
            lngLink = lngLink + 1

            rngCell.ShowPrecedents

            On Error Resume Next
            Set rngPrecedentRange = rngCell.NavigateArrow(True, lngArrow, lngLink)

            If Err.Number <> 0 Then
                Exit Do
            End If

            On Error GoTo 0
            strPrecedentAddress = rngPrecedentRange.Address(False, False, xlA1, True)

            If strPrecedentAddress = rngCell.Address(False, False, xlA1, True) Then
                Exit Do
            Else

                blnNewArrow = False

                If Not dicAllPrecedents.Exists(strPrecedentAddress) Then
                    dicAllPrecedents.Add strPrecedentAddress, lngLevel
                    GetPrecedents rngPrecedentRange, dicAllPrecedents, lngLevel + 1
                End If
            End If
        Loop

        If blnNewArrow Then Exit Do
    Loop

End Sub

 

[Ergun13]

Çok teşekkürler.
Amaca uygun çalıştı.
Ancak Sayfa1 de dahil olmak üzere diğer sayfalarda başvurduğu tüm formülleri etkileyen hücreler de boyandı.

Sayfa1 içinde sayfada yer alan formüllü hücrelerin Sayfa1'de başvurduğu hücreler de boyandı.
Sayfa1'den Sayfa2'deki başvurulan hücreler de boyandı.
Sayfa2'de yer alan formüllerin Sayfa2'de başvurduğu hücreler de boyandı.
Sayfa3'den Sayfa2'deki hücrelere başvuran hücreler de boyandı.
Halbuki bana sadece Sayfa1'in başvurduğu hücreler gerekiyordu.
Sayfa3'ün başvurduğu Sayfa2 hücreler de boyanınca ayrı bir dosyada Sayfa3'ü silerek sadece Sayfa1'in başvurduğu hücreleri boyalı olarak alabildim.
Kodu geliştirmek açısından sadece Sayfa1'in başvurduğu hücrelerin boyanması sağlanabilir mi ?

Emeğinize sağlık. tekrar teşekkürler

 

[mahmut011]

Merhaba,

Çok teşekkürler.

rica ederim.

Sayfa2'de yer alan formüllerin Sayfa2'de başvurduğu hücreler de boyandı.
Sayfa3'den Sayfa2'deki hücrelere başvuran hücreler de boyandı.

Bu iki dediğinizin olmaması lazım, bendeki dosyada test ettim bu şekilde olmuyor.

Set rngToCheck = Sayfa1.UsedRange
bu kodla sadece sayfa1 deki hücrelerin formülerine bakılıyor. Sayfa adları farklı ise burayı Set rngToCheck =Sheets("Sayfaadı").Usedrange olarak da kullanabilirsiniz.

sayfa1 in sayfa1 de başvuru yaptığı hücrelerin boyanmasını istemiyorsanız, renklendirme yapan satırı aşağıdaki kodla değiştirin

If Range(dicAllPrecedents.Keys()(i)).Parent.Name <> "Sayfa1" Then
     Range(dicAllPrecedents.Keys()(i)).Interior.Color = rgbYellow
 End If

 

[Ergun13]

Set rngToCheck = Sayfa1.UsedRange
bu kodla sadece sayfa1 deki hücrelerin formülerine bakılıyor. Sayfa adları farklı ise burayı Set rngToCheck =Sheets("Sayfaadı").Usedrange olarak da kullanabilirsiniz.

Bu çalıştı. Çok teşekkürler

sayfa1 in sayfa1 de başvuru yaptığı hücrelerin boyanmasını istemiyorsanız, renklendirme yapan satırı aşağıdaki kodla değiştirin

Bu etki etmedi.

Benim istediğim şey gerçekleşti.
Tekrar teşekkür ediyorum