VBA run in next row until blank

Chowmann78

New Member
Joined
Dec 7, 2020
Messages
5
Office Version
  1. 365
Platform
  1. Windows
Hi,
I have uses this forum for years and for the first time can't find the exact answer I need so I am hoping someone can point me in the right direction!

This is my formula which checks a range (E4:TH15) in sheet1 and finds the color in K1 and value/text in K2 and then returns the count of these two conditions in to the cell to the left of K2.
Hope I have explained this well?

What I need is for the VBA to check all the cells in column K (K2, K3, K4....) and return the value in the adjacent left cell in each row until a blank cell is found in column K.

Sub CountColorValue()
Dim numbers As Long
Dim Cell As Range
For Each Cell In Sheet1.Range("E4:TH15")
If Cell.Interior.ColorIndex = Range("K1").Interior.ColorIndex Then
If Cell.Value Like Range("K2").Value Then
numbers = numbers + 1
End If
End If
Next Cell
Cells(2, 10).Value = numbers
End Sub

Someone has probably posted this here somewhere but I Just can't find it or figure out what I need to do.
Thanks in advance.
 

Excel Facts

Select all contiguous cells
Pressing Ctrl+* (asterisk) will select the "current region" - all contiguous cells in all directions.
Rich (BB code):
If Cell.Value Like Range("K2").Value Then

You are using the Like operator in the above statement. I am not sure it would work in that syntax, but without some example of what the cells in column K might contain as conmpared to the cells in Range("E4:TH15"), I am not sure what to recommend for a fix. Can you post an example of what might be in column K cells and what could be in the other range so we can see what you are trying to match up?
 
Upvote 0
if Like arguments work correct then
Please Test this (results return at column L (column12):
VBA Code:
Sub CountColorValue()
Dim numbers As Long
Dim Cell As Range
Dim Lastrow As Long
Dim i As LongPtr

Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Lastrow
numbers = 0
For Each Cell In Sheet1.Range("E4:TH15")
If Cell.Interior.ColorIndex = Range("K1").Interior.ColorIndex Then
If Cell.Value Like Range("K" & i).Value Then
numbers = numbers + 1
End If
End If
Next Cell
Cells(i, 12).Value = numbers
Next i
End Sub
 
Upvote 0
Solution
Hi JLGWhiz,
The cells in column K are names, these names are in the range E4:TH15 on sheet1.
I am trying to count the names based on the cell color.
e.g if kerry appears 9 times with red background and 4 times with green background, the formula would return 9 in cell J2 next to the K2 cell as K1 has a red background and K2 has the text kerry.

1607362290232.png
 
Upvote 0
Sorry change
Dim i As LongPtr
to
Dim i As Long
 
Upvote 0
Thank you!
Works with Dim i As LongPtr.
What is the difference?
From MS spec sheet
LongPtr is not a true data type because it transforms to a Long in 32-bit environments, or a LongLong in 64-bit environments. Using LongPtr enables writing portable code that can run in both 32-bit and 64-bit environments. Use LongPtr for pointers and handles.

Either is better than Integer.
 
Upvote 0
From Microsoft Docs:

Note

LongPtr is not a true data type because it transforms to a Long in 32-bit environments, or a LongLong in 64-bit environments. Using LongPtr enables writing portable code that can run in both 32-bit and 64-bit environments. Use LongPtr for pointers and handles.
 
Upvote 0
One more question.

How do I add this to multiple columns as I have various colors to check?

Sub CountColorValue()
Dim numbers As Long
Dim Cell As Range
Dim Lastrow As Long
Dim i As LongPtr

Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Lastrow
numbers = 0
For Each Cell In Sheet1.Range("E4:TH15")
If Cell.Interior.ColorIndex = Range("K1").Interior.ColorIndex Then
If Cell.Value Like Range("K" & i).Value Then
numbers = numbers + 1
End If
End If
Next Cell
Cells(i, 12).Value = numbers
Next i
End Sub

Sub CountColorValue2()
Dim numbers As Long
Dim Cell As Range
Dim Lastrow As Long
Dim i As LongPtr

Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Lastrow
numbers = 0
For Each Cell In Sheet1.Range("E4:TH15")
If Cell.Interior.ColorIndex = Range("M1").Interior.ColorIndex Then
If Cell.Value Like Range("M" & i).Value Then
numbers = numbers + 1
End If
End If
Next Cell
Cells(i, 14).Value = numbers
Next i
End Sub

Sub CountColorValue3()
Dim numbers As Long
Dim Cell As Range
Dim Lastrow As Long
Dim i As LongPtr

Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Lastrow
numbers = 0
For Each Cell In Sheet1.Range("E4:TH15")
If Cell.Interior.ColorIndex = Range("O1").Interior.ColorIndex Then
If Cell.Value Like Range("O" & i).Value Then
numbers = numbers + 1
End If
End If
Next Cell
Cells(i, 16).Value = numbers
Next i
End Sub

Sub CountColorValue4()
Dim numbers As Long
Dim Cell As Range
Dim Lastrow As Long
Dim i As LongPtr

Lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To Lastrow
numbers = 0
For Each Cell In Sheet1.Range("E4:TH15")
If Cell.Interior.ColorIndex = Range("Q1").Interior.ColorIndex Then
If Cell.Value Like Range("Q" & i).Value Then
numbers = numbers + 1
End If
End If
Next Cell
Cells(i, 18).Value = numbers
Next i
End Sub
 
Upvote 0
You can add one more for Loop for column number above For i=2 to lastrow
For Example : For j=5 to 8
and change
1. Range("K1") to Cells (1 , 2 * j + 1)
2. Range("K" & i).Value to Cells (i , 2 * j + 1).value
3. Cells(i, 12).Value to Cells(i , 2 * j + 2).Value

And add Next j after Next i
 
Upvote 0

Forum statistics

Threads
1,213,549
Messages
6,114,261
Members
448,558
Latest member
aivin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top