VBA comparison with ActiveCell.Offset

[haudrauf64]

Hi there!
Sorry in advance for being stupid :-) first time working with VBA (and this forum)...

Goal: Some cells in B1:E1 (TC-0110 = main hazard) may differ to cells in F2:I2 (subhazard to TC-0110). I'd like to build a macro that marks these differences. It should be possible to select an orange cell and the macro does it's job in marking the differences in it's related subhazards.
Screenshot 2022-02-17 at 17.03.12.jpg

Question: I do not get how to apply a NOT-function (or something related) to compare the ranges but in relation to the ActiveCell. As the macro iterates trough the rows below the orange field, it should apply the conditional formatting to where it is at the moment (for example =NOT($B1=F3) when it is relating to TC-0112)

This is what I tried:

Sub ChangeMarker()
Dim Mainhazard As String
Mainhazard = ActiveCell.Value
Mainhazard = Right(ActiveCell.Value, 3)
Dim Subhazard As String
Subhazard = ActiveCell.Offset(i, 0).Value
Subhazard = Right(ActiveCell.Offset(i, 0).Value, 3)
'This should activate the Loop?
For i = 1 To Rows.Count
Next i
'Checks if Subhazard is belonging to the Mainhazard
If Mainhazard - Subhazard < 10 Then
'Select the range where the conditional formatting should apply (--> but does not work with i)
    'Range("F2:I2").Select
    'Range("B1:E1").Offset(1, 4).Select
    Range(ActiveCell.Offset(1, 5), ActiveCell.Offset(1, 8)).Select
'This compares the hazard indicators of the mainhazard (ex. B1:E1) to the hazard indicators of the subhazard (ex.F2:I2)
    'Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=NOT(B$1=F2)"
     Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=NOT(ActiveCell.Offset(0, 1).Range(ActiveCell, ActiveCell.Offset(0, 3))=ActiveCell.Offset(1,5).Range(ActiveCell, ActiveCell.Offset(0,3))"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 5296274
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
End If
End Sub

Thank you so much for any advide. I'm stuck here for ages!
Greetz

[Bob Phillips]

Try this

Sub ChangeMarker()
Dim Mainhazard As String
Dim numSubs As Long
Dim lastrow As Long
Dim i As Long, ii As Long

    With ActiveSheet
    
        lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
        For i = 2 To lastrow
        
            Mainhazard = .Cells(i, "B").Value
            numSubs = Application.CountIf(.Range("B2").Resize(lastrow - 1), Left$(Mainhazard, 5) & "**") - 1
            
            With .Cells(i + 1, "G").Resize(numSubs, 4)
                
                For ii = .FormatConditions.Count To 1 Step -1
                
                    .FormatConditions(ii).Delete
                Next ii
                
                .FormatConditions.Add Type:=xlExpression, _
                                      Formula1:="=" & .Cells(0, -3).Address(True, False) & "<>" & .Cells(1, 1).Address(False, False)
                With .FormatConditions(1)
                
                    .SetFirstPriority
                    
                    With .Interior
                    
                        .PatternColorIndex = xlAutomatic
                        .Color = 5296274
                        .TintAndShade = 0
                    End With
                    
                    .StopIfTrue = False
                End With
            End With
            
            i = i + numSubs
        Next i
    End With
End Sub

[snb]

Conditional format will be your friend.
Please post a sample Excel file

In VBA:

Sub M_snb()
  sn = Range("B1:I6")

  for j = 1 to ubound(sn) step 3
    for jj = 2 to 4
     if sn(j,jj)<> sn(j+1,jj+4) then cells(j+1,jj).interior.colorindex=12
     if sn(j,jj)<> sn(j+2,jj+4) then cells(j+2,jj).interior.colorindex=12
    next
  next
End Sub

[haudrauf64]

Hi Bob!
Sadly does not work...

Would it be an idea that the macro first checks the cells below an then works with the result of the equation?
Example: A1 (TC-0110) is selected. The macro checks the cells below (the yellow ones). If the most right 3 digits substracted are equal to 1-9 it adapts the conditional formatting to the according row.
- TC-0111 minus TC-0110 = 1 (conditional formatting is adapted to the first row below selected starting cell)
- TC-0112 minus TC-0110 = 2 (cf is adapted to the second row below selected starting cell)
- TC-0210 minus TC-0110 = 100 (cf is not adapted as it is not between 1-9)

I'll post a sample Excel file. Please feel free to try and adapt your first suggestion.

Thank you for your time!
Greetz

[haudrauf64]

Hi snb

This marks some cells but does not work properly...

I attached an Excel File. Feel free!

Thank you for your time!

Greetz

[Bob Phillips]

I tested it and it worked fine, or at least as I understood the requirement. Does it not work for you because you said the data started in B1 and my code worked with that, whereas now you say A1.

My code starts at B1, gets the main code, first five characters (e.g. TC-01) and finds how many rows below start with that code and sets conditional formats for those rows. It then moves onto the next block and repeats the process.

Maybe post the workbook, as snb suggested.

[snb]

You didn't add the macro I provided.

Use:

Sub M_snb()
  sn = Range("B1:I6")

  For j = 1 To UBound(sn) Step 3
    For jj = 1 To 4
      If sn(j, jj) <> sn(j + 1, jj + 4) Then Cells(j + 1, jj + 5).Resize(2).Interior.ColorIndex = 22
    Next
  Next
End Sub

In conditional Formatting:

[Bob Phillips]

As I said, it was you changing the details

Sub ChangeMarker()
Dim Mainhazard As String
Dim numSubs As Long
Dim lastrow As Long
Dim i As Long, ii As Long

    With ActiveSheet
    
        lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
        For i = 1 To lastrow
        
            Mainhazard = .Cells(i, "A").Value
            numSubs = Application.CountIf(.Range("A1").Resize(lastrow), Left$(Mainhazard, 5) & "**") - 1
            
            With .Cells(i + 1, "F").Resize(numSubs, 4)
                
                For ii = .FormatConditions.Count To 1 Step -1
                
                    .FormatConditions(ii).Delete
                Next ii
                
                .FormatConditions.Add Type:=xlExpression, _
                                      Formula1:="=" & .Cells(0, -3).Address(True, False) & "<>" & .Cells(1, 1).Address(False, False)
                With .FormatConditions(1)
                
                    .SetFirstPriority
                    
                    With .Interior
                    
                        .PatternColorIndex = xlAutomatic
                        .Color = 5296274
                        .TintAndShade = 0
                    End With
                    
                    .StopIfTrue = False
                End With
            End With
            
            i = i + numSubs
        Next i
    End With
End Sub

[haudrauf64]

Thanks! This works well in the dummysheet-excel. But is there any way to make the "Step 3" part flexible? As there are not always the same amount of subhazards this would be necessary.

See the attached file:

Thanks for your work & patience

[arnelgp]

Public Sub ChangeMarker()


    Const main_sheet As String = "Sheet1"
    
    Dim cel As Range
    Dim last As Long
    Dim i As Long, j As Long
    Dim arr(1 To 4) As String
    
    With Sheets(main_sheet)
        last = .Cells(.Rows.Count, 1).End(xlUp).Row
        For i = 1 To last
            Set cel = .Cells(i, 2)
            With cel
                If Len(.Value & "") Then
                        arr(1) = .Offset(0, 0)
                        arr(2) = .Offset(0, 1)
                        arr(3) = .Offset(0, 2)
                        arr(4) = .Offset(0, 3)
                Else
                    For j = 4 To 7
                        If .Offset(0, j).Value & "" <> arr(j - 3) Then
                            .Offset(0, j).Interior.ColorIndex = 6
                        Else
                            .Offset(0, j).Interior.ColorIndex = -4142
                        End If
                    Next
                End If
            End With
        Next
    End With
End Sub

[haudrauf64]

You're absolutely right. Completely my fault.

Do you have any idea why cell "G3" is formatting even if it's not different?

See attached file:

HazardLog-dummysheet-BOB.xlsm

Thank you & sorry for the inconveniences!

[haudrauf64]

This works perfectly!

Thank you for your time!

[snb]

Sub M_snb()
  sn = Cells(1).CurrentRegion

  For j = 1 To UBound(sn)
    If sn(j, 2) <> "" Then
      For jj = 1 To UBound(sn)
        If j + jj = UBound(sn) Or sn(j + jj, 2) <> "" Then Exit For
      Next
      If jj = 1 Then jj = 2
      For jjj = 2 To 5
        If sn(j, jjj) <> sn(j + 1, jjj + 4) Then Cells(j + 1, jjj + 4).Resize(jj - 1).Interior.ColorIndex = 22
      Next
      j = j + jj - 1
    End If
  Next
End Sub

[haudrauf64]

Hi snb!

This works well in the supplied excel file. I (somewhat) succeeded in adapting the code to a bigger range of data.

But if I change some cells (H6, G3 - should not be formatted) the macro doesn't get it. Do you have an idea why this might occur?

HazardLog-dummysheet_snb.xlsm

Thank you for your time & have a nice weekend
Greetz

[snb]

Posting a representative sample is an art.

Sub M_snb()
  sn = Cells(1).CurrentRegion

  For j = 1 To UBound(sn)
    If sn(j, 2) <> "" Then
      y = j
    Else
      For jj = 2 To 5
        If sn(y, jj) <> sn(j, jj + 4) Then Cells(j, jj + 4).Interior.ColorIndex = 22
      Next
    End If
  Next
End Sub