I am very new to macros, so this is probably a dumb question. I have searched and searched, and have not yet found the answer, so I hope an expert in here will aid me :)
In my code I have a large range that I search through for a certain trait (all cells have either the values "Done", "Ongoing" or "Waiting"). When I find the value "Ongoing", I want to use that cell to create a smaller range, that I will use a counter in. I can, however, not make the subrange work :(
Dim range1 As Range
For Each cell In Sheet2.Range("A5:Y5")
If cell.Value = "Ongoing" Then Set range1 = Cells(cell.Row, cell.Column)
Next cell
i = 0
For Each cell In Sheet2.Range("A5:range1")
If cell.Value = "Done" Then
i = i + 1
End If
Next cell
Here you have a simple code performing some of the actions you want:
Dim rangeToSearch As Range
Dim doneCount As Integer, onGoingCount As Integer, onGoingDones(50) As Integer
Set rangeToSearch = Sheet2.Range("A5:Y5")
doneCount = 0
onGoingCount = 0
For Each cell In rangeToSearch
If (Not IsEmpty(cell)) Then
If LCase(cell.Value) = "done" Then
doneCount = doneCount + 1
ElseIf LCase(cell.Value) = "ongoing" Then
onGoingCount = onGoingCount + 1
onGoingDones(onGoingCount) = doneCount
doneCount = 0
End If
End If
Next cell
It counts the number of "done" (caps does not matter) between "ongoing" cells and store them in an array (onGoingDones; it can just deal with upto 50 elements, but I guess that is more than enough).
Related
I have a spreadsheet that keeps track of project hours. Each project is assigned a color. A row contains half hour increments. Each half hour gets assigned a color based on which project is being worked on during that time.
I want to count the number of changes from one color to another for the length of the row. A row is one day.
How can I do this in Excel?
Below is what a row looks like. Each row is one day. I need to count how many times the color changed in this row left to right. So the output in this case would be 7 because the project changed 7 times.
This is a slightly more condensed UDF:
Function CountColorChanges(rng As Range) As Integer
Dim i As Integer
With rng.Columns
If .Count > 1 Then
For i = 1 To .Count - 1
If rng.Cells(1, i + 1).Interior.Color <> rng.Cells(1, i).Interior.Color Then CountColorChanges = CountColorChanges + 1
Next i
End If
End With
End Function
Option Explicit
Function NumberOfColorChanges(ByVal rng As range)as long
Dim cell As range
Dim color As Long
Dim firstCell As Boolean
firstCell = True
For Each cell In rng
If firstCell = True Then
color = cell.Interior.color
firstCell = False
Else
If color <> cell.Interior.color Then
NumberOfColorChanges = NumberOfColorChanges + 1
color = cell.Interior.color
End If
End If
Next cell
End Function
I need to display a message box when all the values in a range on my spreadsheet are zero. Currently I am using the following code:
Dim Cell As Range
For Each Cell In Range("E17:E25")
If Cell.Value = "0" Then
MsgBox ("If hardware is required, please manually populate the corresponding sections.")
End If
Next
The message is displayed, however it is shown 9 times (for each of the cells in the range). What I need is to check if all the values in the range E17:E25 are zero, and then display only one message box. Any ideas?
Thanks.
You want to know if all the values are 0? You could just do
If WorksheetFunction.Sum(Range("E17:E25")) = 0 Then MsgBox ("If hardware is required, please manually populate the corresponding sections.")
No need for loops.
Edit: If you want to check for any other number, and if all cells are that number, you can do this:
Sub t()
Dim rng As Range
Dim myNum as Long
myNum = 1
Set rng = Range("B3:B6")
If WorksheetFunction.CountIf(rng, myNum) = rng.Count Then MsgBox ("All the same!")
End Sub
And cause there are infinite ways to skin a cat here is another approach.
Dim Cell As Range
Dim ZeroCount As Integer
Dim CellCount As Integer
ZeroCount = 0
CellCount = 0
For Each Cell In Range("E17:E25")
CellCount = CellCount + 1
If Cell.Value = 0 Then ZeroCount = ZeroCount + 1
Next Cell
If ZeroCount = CellCount Then MsgBox ("If hardware is required, please manually populate the corresponding sections.")
To test that:
The range doesn't contain any empty values
All cells are the same
function
Function SameRange(rngIn As Range) As Boolean
If Application.CountA(rngIn) = rngIn.Cells.Count Then SameRange = (Application.CountIf(rngIn, rngIn.Cells(1).Value) = rngIn.Cells.Count)
End Function
test
Sub test()
MsgBox SameRange([d1:d5])
End Sub
'something like this
Dim isDataPresent as boolean
isDataPresent = true
for each Cell in Range(....)
if cell.value = "0" then
isDataPresent = false
exit for
end if
next
if not isDataPresent then
show message box here
end if
I am trying to count the number of cells in a range that has the same color as a reference cells, IF the corresponding cell in another range has the correct value criterion. For example:
If (A1 < 350) and (B1 has the same color as a reference cell), then count 1.
Loop over rows 1 to 15
It is essentially the same problem as the question posted here:
http://www.mrexcel.com/forum/excel-questions/58582-countif-multiple-criteria-one-being-interior-color.html
Unfortunately, it seems that the ExtCell.zip file no longer exit. Hence, I could not simply replicate the given solution. I tried to follow the same approach using the SUMPRODUCT function and I wrote a function for comparing cell color, but it did not work. I got the error "A value used in the formula is of the wrong data type." My code is as follow. I am using Excel 2007 on Windows 7. Any help is appreciated. Thanks!
=SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))
The formula above is keyed into a cell. B57:B65 contain some numerical values, while D57:D65 are colored cells. D307 is the reference cell with the correct color.
'' VBA function ColorCompare
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
Dim rCell As Range
Dim TFresponses() As Boolean 'the boolean array to be returned to SUMPRODUCT
Dim CallerCols As Long 'find out the number of cells input by the user
'so as to define the correct array size
With Application.Caller
CallerCols = .Column.Count
End With
ReDim TFresponses(1 To CallerCols)
Dim Idx As Long
Idx = 1
For Each rCell In compareCells
If rCell.Interior.ColorIndex = refCell.Interior.ColorIndex Then
TFresponses(Idx) = 1
Idx = Idx + 1
Else
TFresponses(Idx) = 0
Idx = Idx + 1
End If
Next rCell
ColorCompare = TFresponses
End Function
There are a couple of issues in your code
You need to determine the size of compareCells, not the caller cell
You are considering columns, should be Rows (or Rows and Columns for maximum flexability)
There are a few optimisations you can make
Here's a refactored version of your Function
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
Dim rCell As Range, rRw As Range
Dim TFresponses() As Boolean 'the boolean array to be returned to SUMPRODUCT
Dim rw As Long, cl As Long
Dim clr As Variant
clr = refCell.Interior.ColorIndex
ReDim TFresponses(1 To compareCells.Rows.Count, 1 To compareCells.Columns.Count)
rw = 1
For Each rRw In compareCells.Rows
cl = 1
For Each rCell In rRw.Cells
If rCell.Interior.ColorIndex = clr Then
TFresponses(rw, cl) = True
End If
cl = cl + 1
Next rCell
rw = rw + 1
Next rRw
ColorCompare = TFresponses
End Function
Note that while this will return a result for any shaped range, to be useful in SumProduct pass it a range either 1 row high or 1 column wide - just as your sample formula does.
Try this (updated for given formula: =SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))):
Sub test()
i = 57
While Not IsEmpty(Cells(i, 1))
If Cells(i, 2) < 350 And Cells(i, 4).Interior.ColorIndex = Cells(307, 4).Interior.ColorIndex Then 'replace with your reference cell
count = count + 1
End If
i = i + 1
Wend
End Sub
Here is the code below:
Public n as Long ' <--above sub procedure
With Sheets("Sheet1").Range("A6").Offset(n, 0)
If n = 0 Then
.Value = 1
Else
.Value = .Parent.Range(.Address).Offset(-1, 0) + 1
End If
n = n + 1
End With
(See pic below) If I delete 4 then click command button again it just reset back to 1. I want to make it static so even I deleted the last value of row it still continue increment from the last value.
Store number
1
2
3
4
Try this:
Sub Test()
Dim trow As Long
With Sheets("Sheet1") '~~> change to suit
trow = .Range("A:A").Find(vbNullString, [A5]).Row
With .Range("A" & trow)
If trow = 6 Then .Value = 1 _
Else .Value = .Offset(-1, 0).Value + 1
End With
End With
End Sub
Above code finds the first blank cells. If it is A6 it assigns a value of 1.
Otherwise it assigns previous cell value plus 1. Is this what you're trying?
Edit1: Explanation
trow = .Range("A:A").Find(vbNullString, [A5]).Row
This finds the first empty row in Column A starting A5.
[A5] is used to return Range("A5") object. So it can also be written as:
trow = .Range("A:A").Find(vbNullString, .Range("A5")).Row
We used a VBA vbNullString constant as What argument in Range Object Find Method.
Find Method returns a Range Object so above can be written also like this:
Sub Test()
Dim r As Range
With Sheets("Sheet1") '~~> change to suit
Set r = .Range("A:A").Find(vbNullString, [A5])
With r
If .Row = 6 Then .Value = 1 _
Else .Value = .Offset(-1, 0).Value + 1
End With
End With
End Sub
What your asking for, a button with memory doesn't sound neatly solvable using just VBA.
You could potentially have a list on a hidden sheet that gets a value added to it each time the commandButton is pressed and it writes the max of the list values back to the target cell?
Alternatively you could investigate using a scrollbar from the form control section of the developer tab with a link to your target cell. I often use this technique for interactive sheets.
Named Range Method
Public sub btnPress
dim val as long
val = Range("PreviousCellValue")
set Range("PreviousCellValue") = val+1
Sheets("Sheet1").Range("A6").Offset(n, 0).value = Range("PreviousCellValue")
End sub btnPress
I'm trying to write a macro to change the colors of rows when the values in column B change. Column A will be my controlling column using 1's and 0's, i.e. column A will stay a 1 as long as column B stays the same; whenever B changes, A will flip to a 0, and so on.
I can get it to color the rows correctly when the values in column B change, but the problem arises when I filter the data. For example: let's say I have B2-B4 set to "test1", B5-B7 set to "test2", and B8-B10 set to "test3", then I filter column B to not include "test2". Originally, the rows would be colored differently where the column values changed, but rows B2-B4 and B8-B10 are set to the same color and now they're touching since the "test2" rows are hidden.
Here's the code I used to color the rows, but it doesn't work for filtering:
Sub ColorRows()
Dim This As Long
Dim Previous As Long
Dim LastRow As Long
Dim Color As Integer
Dim R As Long
LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
RwColor = Array(15,0)
Color = 0
For R = 2 To LastRow
This = Cells(R, 1).Value
Previous = Cells(R - 1, 1).Value
If This <> Previous Then Color = 1 - Color
Range("A" & R & ":M" & R).Select
Selection.Interior.ColorIndex = RwColor(Color)
Next R
End Sub
How can I fix it so that even after filtering the rows are colored correctly when there is a change in column values?
Here's a way to do this:
1.) Insert the code below as a UDF in a code module.
2.) Then put the formula in A, as A2: =analyseVisible(B2).
This will compare B-cells to the next visible cell above and result in a 'rank'-counter in A.
Now that the counter in A in contiunous (even if rows are hidden), you can use MOD 2 to color it with conditional formatting:
3.) Add a conditional format (from A2 for the whole table): =MOD($A2,2)=1 and set the fill color.
If you use the filter now or change values in B, the rows are re-colored in realtime.
Public Function analyseVisible(r As Range) As Integer
Dim i As Long
If Application.Caller.Row <= 2 Or _
r.Row <> Application.Caller.Row Then
analyseVisible = 1
Exit Function
End If
i = r.Row - 1
While r.Worksheet.Rows(i).Hidden And i > 1
i = i - 1
Wend
If i = 1 Then
analyseVisible = 1
Else
analyseVisible = r.Worksheet.Cells(i, Application.Caller.Column).Value
If r.Worksheet.Cells(i, r.Column).Value <> _
r.Value Then analyseVisible = analyseVisible + 1
End If
End Function
The code below handles the issue by checking only the used & visible rows. It works pretty well, but I was unable to figure out how to fire it when the filter changes. It also does it's comparisons directly on the values that are changing.
Private Sub colorRows()
Dim this As Variant
Dim previous As Variant
Dim currentColor As Long
Dim rng As Range 'visible range
Dim c As Range ' cell
' pick a color to start with
currentColor = vbYellow
' rng = used and visible cells
Set rng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
For Each c In rng ' For each cell that is visible and used
If Not c.Row = 1 Then ' skip header row
this = c.Value
'some simple test logic to switch colors
If this <> previous Then
If currentColor = vbBlue Then
currentColor = vbYellow
ElseIf currentColor = vbYellow Then
currentColor = vbBlue
End If
End If
'set interior color
c.Interior.color = currentColor
previous = this
End If
Next c
End Sub
Then, in the module of the worksheet that you want to colorize, call the sub from the Worksheet_Activate() event. (In reality, you probably want a different event. I mostly work with Access, so I don't really know what's available to you. I'm just trying to point you in the right direction to what I'm sure is your next question if you stick with the method you started with.)
Private Sub Worksheet_Activate()
colorRows
End Sub