VBA Loop through column range and Offset the output

[Giggs1991]

Hi All,

I have the following data in column A of a worksheet starting from cell A1:

Column A Column B
====== ============
xxx
ABC
xxx
123
4567
876

I am looking for VBA code that will colour the cell in column B in yellow if the cell to the left in column A contains "xxx" or "XXX". It should also mention " over allocated" in column B if the cell to the left in column A has a value greater than 1000.

I have attached the expected output

 

[bebo021999]

Try:

Option Explicit
Sub color()
Dim lr&, cell As Range
lr = Cells(Rows.Count, "A").End(xlUp).Row
With Range("B1:B10000")
    .Interior.color = xlNone
    .ClearContents
End With
For Each cell In Range("A1:A" & lr)
    If LCase(cell) Like "xxx" Then cell.Offset(, 1).Interior.color = vbYellow
    If IsNumeric(cell) And cell > 1000 Then cell.Offset(, 1).Value = "Over allocated"
Next
End Sub

P/S: update

 

[Trebor76]

Hi Giggs1991,

Try this:

Option Explicit
Sub Macro1()

    Dim rngCell As Range
    
    Application.ScreenUpdating = False
    
    For Each rngCell In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
        If StrConv(rngCell, vbUpperCase) = "XXX" Then
            rngCell.Offset(0, 1).Interior.Color = RGB(255, 255, 0)
        ElseIf Val(rngCell) > 1000 Then
            rngCell.Offset(0, 1).Value = "Overallocated"
        End If
    Next rngCell
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

 

[Giggs1991]

Try:

Option Explicit
Sub color()
Dim lr&, cell As Range
lr = Cells(Rows.Count, "A").End(xlUp).Row
With Range("B1:B10000")
    .Interior.color = xlNone
    .ClearContents
End With
For Each cell In Range("A1:A" & lr)
    If LCase(cell) Like "xxx" Then cell.Offset(, 1).Interior.color = vbYellow
    If IsNumeric(cell) And cell > 1000 Then cell.Offset(, 1).Value = "Over allocated"
Next
End Sub

P/S: update

Looks good thank you. However, could you please make this event driven. That is, if someone types in a value in column A that contains "xxx" or "XXX" or a number greater than 1000, the above code should run automatically?

 

[Trebor76]

could you please make this event driven. That is, if someone types in a value in column A that contains "xxx" or "XXX" or a number greater than 1000, the above code should run automatically?

Try this on the sheet in question i.e. not in a stand alone module like the above macros:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo ErrTrap

    If Target.Column = 1 Then
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        If IsNumeric(Target.Value) = False Then
            If StrConv(Target.Value, vbUpperCase) = "XXX" Then
                Target.Offset(0, 1).Interior.Color = RGB(255, 255, 0)
            End If
        Else
            If Val(Target.Value) > 1000 Then
                Target.Offset(0, 1).Value = "Overallocated"
            End If
        End If
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End If
    
Exit Sub

ErrTrap:

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

 

[Giggs1991]

Try this on the sheet in question i.e. not in a stand alone module like the above macros:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

On Error GoTo ErrTrap

    If Target.Column = 1 Then
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        If IsNumeric(Target.Value) = False Then
            If StrConv(Target.Value, vbUpperCase) = "XXX" Then
                Target.Offset(0, 1).Interior.Color = RGB(255, 255, 0)
            End If
        Else
            If Val(Target.Value) > 1000 Then
                Target.Offset(0, 1).Value = "Overallocated"
            End If
        End If
        With Application
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End If
   
Exit Sub

ErrTrap:

    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With

End Sub

Awesome! works well. Thank you

 

[bebo021999]

Right click on sheet name, View Code then paste below code into:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns(1)) Is Nothing Or Target.Count > 1 Then Exit Sub
With Target.Offset(, 1)
    If LCase(Target) Like "xxx" Then .Interior.color = vbYellow
    If IsNumeric(Target) And Target > 1000 Then .Value = "Over allocated"
End With
End Sub

 

[Giggs1991]

Right click on sheet name, View Code then paste below code into:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns(1)) Is Nothing Or Target.Count > 1 Then Exit Sub
With Target.Offset(, 1)
    If LCase(Target) Like "xxx" Then .Interior.color = vbYellow
    If IsNumeric(Target) And Target > 1000 Then .Value = "Over allocated"
End With
End Sub

Thank you

 

[Giggs1991]

Right click on sheet name, View Code then paste below code into:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns(1)) Is Nothing Or Target.Count > 1 Then Exit Sub
With Target.Offset(, 1)
    If LCase(Target) Like "xxx" Then .Interior.color = vbYellow
    If IsNumeric(Target) And Target > 1000 Then .Value = "Over allocated"
End With
End Sub

There is one more thing I noticed when I ran the code. Is it possible to add some VBA so that if I change the contents of a cell in Column A from "xxx" or "XXX" to something else, the yellow coloured cell next to it should revert back to no colour.

 

[bebo021999]

Try again:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Columns(1)) Is Nothing Or Target.Count > 1 Then Exit Sub
With Target.Offset(, 1)
    If LCase(Target) Like "xxx" Then 
                 .Interior.color = vbYellow
    else 
                 .Interior.color = xlNone
    End If
    If IsNumeric(Target) And Target > 1000 Then .Value = "Over allocated"
End With
End Sub