Ms project özelliği, değişiklik vurgulama makrosu

[Quesera]

Merhaba arkadaşlar,

Ms projectte var olan, hücre ve hücreye bağlı değişen hücreler başka bir işlem yapıncaya dek başka renk oluyor. Bunu excelde de oluşturmak istiyorum ancak makrosunu yazamadım. Bilen ve yardımcı olabilecek var mı?

 

[Muzaffer Ali]

Merhaba.
Koşullu biçimlendirmeyi inceleyin.
Eğer yapamazsanız detay verin yardımcı olalım.

 

[pitchoute]

Merhaba, deneyip sonucu paylaşabilir misiniz;

Option Explicit

Dim LastChangedCell As Range
Dim AffectedCells As Range
Dim DefaultColor As Long

Private Sub Workbook_Open()
    DefaultColor = RGB(255, 255, 255)
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    On Error GoTo ErrorHandler
    Application.EnableEvents = False
    ClearPreviousHighlights
    Set LastChangedCell = Target
    Target.Interior.Color = RGB(255, 255, 0)
    Set AffectedCells = FindAffectedCells(Target)
    
    If Not AffectedCells Is Nothing Then
        AffectedCells.Interior.Color = RGB(255, 220, 130)
    End If
    Application.EnableEvents = True
    Exit Sub
    
ErrorHandler:
    Application.EnableEvents = True
    MsgBox "Hata oluştu: " & Err.Description, vbExclamation
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error GoTo ErrorHandler
    
    If Not IntersectRange(Target, LastChangedCell) And Not IntersectRange(Target, AffectedCells) Then
        ClearPreviousHighlights
    End If
    Exit Sub
    
ErrorHandler:
    MsgBox "Hata oluştu: " & Err.Description, vbExclamation
End Sub

Private Function FindAffectedCells(ByVal ChangedCell As Range) As Range
    Dim cell As Range
    Dim formulaCell As Range
    Dim ws As Worksheet
    Dim affectedRange As Range
    Set ws = ChangedCell.Worksheet
    For Each cell In ws.UsedRange
        If cell.HasFormula Then
            If InStr(cell.Formula, ChangedCell.Address(False, False)) > 0 Or _
               InStr(cell.Formula, ChangedCell.Address(True, True)) > 0 Then
                If affectedRange Is Nothing Then
                    Set affectedRange = cell
                Else
                    Set affectedRange = Union(affectedRange, cell)
                End If
            End If
        End If
    Next cell
    Set FindAffectedCells = affectedRange
End Function

Private Sub ClearPreviousHighlights()
    If Not LastChangedCell Is Nothing Then
        LastChangedCell.Interior.Color = DefaultColor
    End If
    
    If Not AffectedCells Is Nothing Then
        AffectedCells.Interior.Color = DefaultColor
    End If
    
    Set LastChangedCell = Nothing
    Set AffectedCells = Nothing
End Sub

Private Function IntersectRange(ByVal rng1 As Range, ByVal rng2 As Range) As Boolean
    IntersectRange = False
    If rng1 Is Nothing Or rng2 Is Nothing Then
        Exit Function
    End If
    
    If Not Application.Intersect(rng1, rng2) Is Nothing Then
        IntersectRange = True
    End If
End Function

ThisWorkbook kısmına Workbook_Open prosedürünü ekleyin.

 

[Quesera]

Merhaba, ilginiz için teşekkür ederim. Kodu denedim. Kodla ilgili yaşadığım problemler şu şekilde;
1. Tabloda değişiklikleri görmek istediğim alan F:H aralığı, aralık belirtebilir miyiz? (Bu aralıklar F:F Duration G:G Start Date H:H Finish Date)
2. Hücrede değişiklik yaptığımda etkilenen hücreler yani değişenler siyah dolgulu oluyor, renk kodu neden çalışmıyor anlamadım o kısmı.
3. Undo etkisiz kalıyor. Geri alma işlemi yapmama izin vermiyor.
4. Başka bir değişiklik daha yaptığımda o da siyah oluyor, eski siyah olanlar kendi orjinal rengine geri dönmüyor. MS project mantığında ise hücre eski rengine geri döner.

 

[pitchoute]

Merhaba hocam, şu şekilde dener misiniz;

Option Explicit

Private OriginalColors As Object

Private Sub Worksheet_Activate()
    If OriginalColors Is Nothing Then
        Set OriginalColors = CreateObject("Scripting.Dictionary")
    End If
    Application.EnableEvents = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim RelevantTarget As Range
    Dim ChangedCell As Range
    Dim DependentsRange As Range
    Dim DepCell As Range
    Dim TargetCell As Range

    If OriginalColors Is Nothing Then
        Set OriginalColors = CreateObject("Scripting.Dictionary")
    End If

    Set RelevantTarget = Application.Intersect(Target, Me.Range("F:H"))
    If RelevantTarget Is Nothing Then Exit Sub

    On Error GoTo ErrorHandler
    Application.EnableEvents = False

    ClearPreviousHighlights

    For Each TargetCell In RelevantTarget.Cells
        If Not OriginalColors.Exists(TargetCell.Address) Then
            OriginalColors.Add TargetCell.Address, TargetCell.Interior.ColorIndex
        End If
        TargetCell.Interior.Color = RGB(255, 255, 0)

        On Error Resume Next
        Set DependentsRange = TargetCell.Dependents
        On Error GoTo ErrorHandler

        If Not DependentsRange Is Nothing Then
            For Each DepCell In DependentsRange.Cells
                If Not OriginalColors.Exists(DepCell.Address) Then
                    OriginalColors.Add DepCell.Address, DepCell.Interior.ColorIndex
                End If
                DepCell.Interior.Color = RGB(255, 165, 0)
            Next DepCell
        End If
        Set DependentsRange = Nothing
    Next TargetCell

Cleanup:
    Application.EnableEvents = True
    Exit Sub

ErrorHandler:
    MsgBox "Hata oluştu (Worksheet_Change): " & Err.Description, vbExclamation
    ClearPreviousHighlights
    Resume Cleanup
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim HighlightedRange As Range
    Dim CellAddr As Variant
    Dim SingleCell As Range

    If OriginalColors Is Nothing Then Exit Sub
    If OriginalColors.Count = 0 Then Exit Sub

    On Error GoTo ErrorHandler

    For Each CellAddr In OriginalColors.Keys
        On Error Resume Next
        Set SingleCell = Me.Range(CellAddr)
        On Error GoTo ErrorHandler

        If Not SingleCell Is Nothing Then
            If HighlightedRange Is Nothing Then
                Set HighlightedRange = SingleCell
            Else
                Set HighlightedRange = Union(HighlightedRange, SingleCell)
            End If
        End If
        Set SingleCell = Nothing
    Next CellAddr

    If HighlightedRange Is Nothing Then
        OriginalColors.RemoveAll
        Exit Sub
    End If

    If Application.Intersect(Target, HighlightedRange) Is Nothing Then
        Application.EnableEvents = False
        ClearPreviousHighlights
        Application.EnableEvents = True
    End If

Cleanup:
    Set HighlightedRange = Nothing
    Exit Sub

ErrorHandler:
    MsgBox "Hata oluştu (Worksheet_SelectionChange): " & Err.Description, vbExclamation
    If Not Application.EnableEvents Then Application.EnableEvents = True
    Resume Cleanup
End Sub

Private Sub ClearPreviousHighlights()
    Dim CellAddr As Variant
    Dim CellToRestore As Range

    If OriginalColors Is Nothing Then Exit Sub
    If OriginalColors.Count = 0 Then Exit Sub

    On Error Resume Next

    For Each CellAddr In OriginalColors.Keys
        Set CellToRestore = Nothing
        Set CellToRestore = Me.Range(CellAddr)
        If Not CellToRestore Is Nothing Then
            CellToRestore.Interior.ColorIndex = OriginalColors(CellAddr)
        End If
    Next CellAddr

    OriginalColors.RemoveAll
    Set CellToRestore = Nothing
    On Error GoTo 0
End Sub

Kod hücrenin rengini değiştirdiği anda, Excel'in geri alma (Undo) hafızası sıfırlanır. Maalesef, bu tür bir otomasyon yaparken Undo özelliğini korumanın doğrudan bir yolu yok hocam.

 

[Quesera]

Loom Message - 26 March 2025

Use Loom to record quick videos of your screen and cam. Explain anything clearly and easily – and skip the meeting. An essential tool for hybrid workplaces.

www.loom.com

3. madde gerçekleşemiyorsa, 1 ve 4 deki aynı sorundan devam ediyor. 4 bu sefer başka bir hücrede değişiklik yapmamı beklemeden süre bazlı çalışıyor.
Loom linkinden kodun çalışmasını izleyebilirsiniz.