Problems with offsetting loops on excel vba

[hunter123]

Hello everyone!


I have a small piece of code that will be used to compare a column (D) with the values of columns A B and C. It will later compare the column E with B and C.

One of the objectives is to compare each cell from D and E with the correspondent cells in A B and C. Example:

If D1 is < A1 + B1 and > A1 + C1, then the color comes in black, else it comes in red
If E1 is between B1 and C1, color comes in black, else comes in red.

I got the code working and to run each line and changing the colors. My main concern starts here. Every day i'll need to add 2 more columns and repeat the process. Ex: If F and G were added, in F column i would need to repeat the process in D (the values stay the same - as in, a b and c). Same goes for G (same as E).
Overall, i need the code to loop for the most columns up until it shows no values.

This is the code i have at the moment

Sub ComparacaoTolerancias()

    Dim i As Long
    Dim j As Long
    Dim lastrow As Long
    Dim ws As Worksheet

    Set ws = Folha1
    

    For i = 1 To 500000
        
        If IsEmpty(ws.Range("D" & i)) Then
            Exit For
        End If

       
        If ws.Range("D" & i).Value <= ws.Range("A" & i).Value + ws.Range("B" & i).Value And ws.Range("D" & i).Value >= ws.Range("A" & i) + ws.Range("C" & i).Value Then
                
                    ws.Range("D" & i).Font.Color = vblack
                    
                    Else: ws.Range("D" & i).Font.Color = vbRed
                   
        End If
            
        If ws.Range("E" & i).Value <= ws.Range("B" & i).Value And ws.Range("E" & i).Value >= ws.Range("C" & i).Value Then
                    
                    ws.Range("E" & i).Font.Color = vblack
                    
                    Else: ws.Range("E" & i).Font.Color = vbRed
                    
        End If
        
    
    Next i
    
    MsgBox ("End")
    
End Sub

I'd appreciate every suggestion
Thank you so much!!

 

[DanteAmor]

Welcome to the forum!

Try this

Sub ComparacaoTolerancias()
    Dim i As Long, j As Long, ws As Worksheet
    
    Set ws = Folha1
    For j = 4 To ws.Cells(1, Columns.Count).End(xlToLeft).Column Step 2
        For i = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row
            If ws.Cells(i, j).Value <= ws.Range("A" & i).Value + ws.Range("B" & i).Value And _
               ws.Cells(i, j).Value >= ws.Range("A" & i) + ws.Range("C" & i).Value Then
                ws.Cells(i, j).Font.Color = vblack
            Else
                ws.Cells(i, j).Font.Color = vbRed
            End If
            If ws.Cells(i, j + 1).Value <= ws.Range("B" & i).Value And _
               ws.Cells(i, j + 1).Value >= ws.Range("C" & i).Value Then
                ws.Cells(i, j + 1).Font.Color = vblack
            Else
                ws.Cells(i, j + 1).Font.Color = vbRed
            End If
        Next i
    Next j
    MsgBox "End"
End Sub

 

[Leith Ross]

Hello hunter123,

When working with large amounts of data in Excel and using VBA, it is much faster to read the data values into an array rather than directly manipulate cells. I have amended your macro to use an array for speed and to make comparing the offsets easier. This will use the last 2 columns on the worksheet and compare them to sum of the offset cells,=.

Sub ComparacaoTolerancias()


    Dim Data    As Variant
    Dim i       As Long
    Dim j       As Long
    Dim Rng     As Range
    Dim ws      As Worksheet


        Set ws = Folha1
    
        Set Rng = ws.Range("A1").CurrentRegion
        
        Data = Rng.Value
    
            ' // First to last row.
            For i = 1 To UBound(Data, 1)
        
                ' // Start with the last 2 columns.
                For j = UBound(Data, 2) - 1 To UBound(Data, 2)
                
                    If VarType(Data(i, j)) = vbEmpty Then GoTo Finished
                    
                    ' // Compare offset columns to current column.
                    If Data(i, j) <= (Data(i, j - 3) + Data(i, j - 2)) And Data(i, j) >= (Data(i, j - 3) + Data(i, j - 1)) Then
                        ws.Cells(i, j).Font.Color = vbBlack
                    Else
                        ws.Cells(i, j).Font.Color = vbRed
                    End If
                Next j
            Next i
            
Finished: MsgBox ("End")
    
End Sub

 

[hunter123]

DanteAmor and Leith Ross, thank you so much for your help. I think i might end up going with DanteAmor answer since it highlighted every cell whereas the second method got to fill only the last column. I'm sure with a few tweaks it will do just the same but for the time being, i'm not going to experiment with it.

I'm truly grateful for your time and your help. Cheers and have a nice day!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.