Can anybody write VBA for this?
[If D10 is greater than 90] or [If E10 equals 2.6 or is greater than 11.99] then fill A10 red
If A10 is filled red and matches any other values in Column A, fill those red too.
Repeat for every row after 10
Can anybody write VBA for this?
[If D10 is greater than 90] or [If E10 equals 2.6 or is greater than 11.99] then fill A10 red
If A10 is filled red and matches any other values in Column A, fill those red too.
Repeat for every row after 10
I have the following code which does something slightly similar but with different criteria and different "then". With enough trial and error I might be able to figure out how to get it transferred into what I need, but I'm guessing some expert here could probably do it in a couple minutes?
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundRng As Range
Dim sAddr As String
For Each rng In Range("B10:B" & LastRow)
If rng.DisplayFormat.Interior.Color = 5287936 And rng <> "" Then
If rng.Offset(0, 4) <> "" Then
rng.EntireRow.Select
ElseIf rng.Offset(0, 4) = "" Then
Set foundRng = Range("A:A").Find(rng.Offset(0, -1), LookIn:=xlValues, lookat:=xlWhole)
If Not foundRng Is Nothing Then
sAddr = foundRng.Address
Do
If foundRng.Offset(0, 5) <> "" Then
foundRng.EntireRow.Select
Exit Do
End If
Set foundRng = Range("A:A").FindNext(foundRng)
Loop While foundRng.Address <> sAddr
sAddr = ""
End If
End If
End If
Next rng
Application.ScreenUpdating = True
Dim lastCell As Long, p As Long
lastCell = Range("A:A").Find("*", , , , , xlPrevious).Row
ActiveCell.Interior.Color = 5296274
For p = 3 To lastCell
If Cells(p, 1).Value = ActiveCell.Value Then Cells(p, 1).Resize(, 15).Interior.Color = ActiveCell.Interior.Color
Next p
Display More
This should get you started.
Sub Button1_Click()
Dim sh As Worksheet
Dim LstRw As Long
Dim Rng As Range, c As Range
'-----------------------------
Dim Lr As Long
Dim Lrng As Range, L As Range
Set sh = Sheets("Sheet1")
With sh
LstRw = .Cells(.Rows.Count, "D").End(xlUp).Row
Lr = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Lrng = .Range("A10:A" & Lr)
Set Rng = .Range("D10:D" & LstRw)
For Each c In Rng.Cells
If c > 90 Then
If c.Offset(, 1) = 2.6 Or c.Offset(, 1) > 11.99 Then
Cells(c.Row, "A").Interior.Color = vbRed
'------------------
For Each L In Lrng.Cells
If L = .Cells(c.Row, 1).Value Then L.Interior.Color = vbRed
Next L
'-------------------
End If
End If
Next c
End With
End Sub
Display More
It doesn't seem to do anything. I'm probably missing something obvious.
Sample file attached.
Ah yes...
Sub Button1_Click()
Dim sh As Worksheet
Dim LstRw As Long
Dim Rng As Range, c As Range
'-----------------------------
Dim Lr As Long
Dim Lrng As Range, L As Range
Set sh = Sheets("Sheet1")
With sh
LstRw = .Cells(.Rows.Count, "D").End(xlUp).Row
Lr = .Cells(.Rows.Count, "A").End(xlUp).Row
Set Lrng = .Range("A10:A" & Lr)
Set Rng = .Range("D10:D" & LstRw)
For Each c In Rng.Cells
If c > 90 Or c.Offset(, 1) = 2.6 Or c.Offset(, 1) > 11.99 Then
Cells(c.Row, "A").Interior.Color = vbRed
'------------------
For Each L In Lrng.Cells
If L = .Cells(c.Row, 1).Value Then L.Interior.Color = vbRed
Next L
'-------------------
End If
Next c
End With
End Sub
Display More
Absolutely brilliant!
Hi Dave,
Your above code doesn't work in excel 2019. Are you able to tell what is the matter?
I can't see anything in that code that would need changing for Excel 2019.
I can't understand why you would want to use VBA instead of Conditional Formatting which would be much more efficient.
Nm I figured out the problem, something in the new data import from txt was messing up the VBA, I changed it to the legacy import and now the vba works.
Don’t have an account yet? Register yourself now and be a part of our community!