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.