Public Function ColorSum(ByVal target As range, ByVal MyColor As String)
Dim Blacksum As Long, Othersum As Long, cel As range
Application.Volatile
Blacksum = 0
Othersum = 0
For Each cel In target
If IsNumeric(cel.Value) Then
If cel.Font.ColorIndex = 1 Then
Blacksum = Blacksum + cel.Value
Else
Othersum = Othersum + cel.Value
End If
End If
Next cel
ColorSum = IIf(LCase(MyColor) = "black", Blacksum, Othersum)
End Function
I am using the above code to calculate black colored sum totals and red colored sum totals in different rows of the excel sheet, but as you know there is a Automatic black color in Font options, when I am entering values with that Automatic color ( Black ) it doesn't sum under Black total, the Automatic Color (Black) cell value's total goes to Red color total instead of Black color total sum, I want the Automatic Black sum total should be included on Black sum total.
I am using
A11=colorsum(A1:A10,"black")
A11=colorsum(A1:A10,"red")
xlColorIndexNone (and xlNone) is a constant with a value of -4142.
xlColorIndexAutomatic (and xlAutomatic) is a constant with a value of -4105.
Using Excel's GUI to set a cell's colour to be "Automatic" will often set the ColorIndex to 1 but, if it was another colour before being set, it will set the ColorIndex to -4105 (i.e. xlColorIndexAutomatic).
So I would suggest you check for each of 1, xlColorIndexNone (or xlNone), and xlColorIndexAutomatic (or xlAutomatic).
In other words, change
If cel.Font.ColorIndex = 1 Then
to
If cel.Font.ColorIndex = 1 Or _
cel.Font.ColorIndex = xlColorIndexNone Or _
cel.Font.ColorIndex = xlColorIndexAutomatic Then
Long time ago I programmed vba but I think that the color index = 0 or xlNone or xlColorIndexAutomatic or xlColorIndexNone is the automatic and Black has colorIndex =1 and that is the reason. Could you try and play with the above mentioned suggested values?
using ColorIndex as reference can be difficult because you'll have to memorize the index. i'd suggest use color
Function SumByFontColor(MyRange As Range, Optional MyColor As Range)
Dim Rng As Range
Dim Col As Long
Application.Volatile
If MyColor Is Nothing Then
Col = Application.Caller.Font.Color
Else
Col = MyColor(1).Font.Color
End If
SumByFontColor = 0
For Each Rng In MyRange
If Rng.Font.Color = Col Then
SumByFontColor = SumByFontColor + Rng.Value2
End If
Next Rng
End Function
there are two ways to use the formula, i hope the code is self explanatory:
it must be noted that updating the color of a cell does not initiate the sheet to recalculate its formulas. So you must manually press F9 to recalculate each time you update the cell's color.
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 am trying to make a sub where the macro counts all the rows containing data (it isn't a set amount, it varies) and then picks a random number between 6 (to exclude headers) and the number of counted rows and highlights the corresponding row. Unfortunately the code I've been working on doesn't do what I need it to do. It does select and highlight a random row, but it selects empty rows too, not only the ones with data. Any ideas where I went wrong?
Sub RandomRow()
Dim mrg As Worksheet
Dim Count As Integer, myRange As Range
Set mrg = ActiveWorkbook.Sheets("Merged")
mrg.Range("A6:K200000").Interior.Color = RGB(255, 255, 255) 'reset cell colours
Set myRange = mrg.Columns("A:A")
Count = Application.WorksheetFunction.CountA(myRange)
myValue = Int((Count * Rnd) + 6) ' Generate random value between 6 and the number of filled rows'.
mrg.Range("A" & myValue).EntireRow.Interior.Color = RGB(255, 255, 153) 'highlight a random row
End Sub
The current value you have for count is misleading. Say it is 20, and the rows extend to 200; you cannot use the value 20 to identify the occupied rows amongst the 200 (unless you created a map/array to store all of the occupied row-numbers, and then choose randomly from these).
You could still determine the CountA if this information is useful to you, but not as part of the random selection process. Better to just find where the last occupied cell is, using End(xlUp).
Now you know the range containing the occupied cells and can choose randomly between these rows. Repeat the generation of a random number until you discover a cell/row that is not empty.
Sub RandomRow()
Dim wsMerged As Worksheet
Dim myRange As Range
Dim count As Long
Dim randRow As Long
Dim occupied As Boolean
Set wsMerged = Worksheets("Merged")
wsMerged.Range("A6:K200000").Interior.Color = RGB(255, 255, 255) 'reset cell colours
Set myRange = wsMerged.Columns("A:A")
'count = Application.WorksheetFunction.CountA(myRange)
count = Range("A200000").End(xlUp).Row - 6
Randomize 'necessary when using Rnd()
Do
randRow = CLng((count * Rnd()) + 6)
'if the cell isn't empty
If wsMerged.Range("A" & randRow).Value <> "" Then
'flag that we are done
occupied = True
wsMerged.Range("A" & randRow).Resize(1, 11).Interior.Color = RGB(255, 255, 153)
End If
Loop While Not occupied
End Sub
To clear cell colours I would set .Interior.ColorIndex = xlColorIndexNone.
At first MyValue is not declared.
Dim MyValue as Long
Now, its better. Secondly, your macro highlight all row, but clear colors only from A to K column. You would rather highlight first 11 columns, wouldn't you?
mrg.Range("A" & myValue).Resize(1, 11).Interior.Color = RGB(255, 255, 153)
And, to answer your question, set myRange like that:
Set myRange = mrg.Range("A6:A200000")
Then your Count worksheet function will not count headings actually. I hope, this helped.
I need to assign the value 1 or 0 based on the color of my cells (Red or Blue). I've heard alot about how to assign colors to values but not the other way. Im a beginner but I believe I will need to use an IF Statement in VBA for this, I haven't figured out how to assign a color as an input for an IF statement. Any help would be appreciated!
Thank You
Excel 2013
In the first example that follow I made the assumption that you want blue cells equal to 1 and red cells equal to 0.
Sub ifBlueMakeCellValueEQ1()
Dim r As Range
Dim rCell As Range
Set r = Selection.Cells
For Each rCell In r
With rCell
Select Case .Interior.Color
Case Is = vbBlue
.Value = 1
Case Is = vbRed
.Value = 0
End Select
End With
Next
End Sub
to use this, first select a range of cells then run the macro.
If that works then ignore the remainder of this answer
If the values of your cells aren't changing to 1 or 0 it means your cell's colors aren't equal to excel's idea of blue and red (vbBlue and vbRed, respectively).
If you run into this problem do this: click on a 'blue' cell. Go to the VBE Immediate window, type the command "?activecell.interior.colorindex", hit enter. The integer that is returned should be used in the following code in place of {BLUECOLORINDEX}
Sub ifBlueMakeCellValueEQ1()
Dim r As Range
Dim rCell As Range
Set r = Selection.Cells
For Each rCell In r
If rCell.Interior.ColorIndex = {BLUECOLORINDEX} Then rCell.Value = 1
Next
End Sub
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
I wanted to use this code
Sub PieMarkers()
Dim chtMarker As Chart
Dim chtMain As Chart
Dim intPoint As Integer
Dim rngRow As Range
Dim lngPointIndex As Long
Dim x As Long
Dim myTheme As String
Application.ScreenUpdating = False
Set chtMarker = ActiveSheet.ChartObjects("chtMarker").Chart
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart
Set chtMain = ActiveSheet.ChartObjects("chtMain").Chart
Set rngRow = Range(ThisWorkbook.Names("PieChartValues").RefersTo)
For Each rngRow In Range("PieChartValues").Rows
chtMarker.SeriesCollection(1).Values = rngRow
SetColorScheme chtMarker, x
chtMarker.Parent.CopyPicture xlScreen, xlPicture
lngPointIndex = lngPointIndex + 1
chtMain.SeriesCollection(1).Points(lngPointIndex).Paste
x=x+1
Debug.Print rngColors.address()
Next
lngPointIndex = 0
Application.ScreenUpdating = True
End Sub
Sub SetColorScheme(cht As Chart, i As Long)
Dim y_off As Long, rngColors As Range
Dim x As Long
y_off = i Mod 13
'this is the range of cells which has the colors you want to apply
Set rngColors = ThisWorkbook.Sheets("Basic").Range(ThisWorkbook.Sheets("Basic").Range("A19").Value).Offset(y_off, 0)
With cht.SeriesCollection(1)
'loop though the points and apply the corresponding fill color from the cell
For x = 1 To .Points.Count
.Points(x).Format.Fill.ForeColor.RGB = _
rngColors.Cells(x).Interior.Color
Next x
End With
End Sub
to colour several pie charts with all of them having the same amount of slices (3 each, 8 pie charts) according to specified colours in the workbook (colours used as background colour for a cell in a worksheet).This is the Sub Colour Scheme.
The code compiles without error the problem is just that it only uses the first to specified colours in a range (say A10:Z10, only the colours in A10 and B10 to colour all pieces of the 8 pie charts (24 sclices in total with the two colours from A10 and B10). Could somebody tell me what I would need to change so that the whole colour range from A10 to X10 is used (24 different colours) for the different slices?
It seems the For loop that use cht.SeriesCollection(1).Points.Count as a boundary doesn't take you beyond two iterations.
You should rather use an inner loop specific to the range of cells you want to retrieve the color from and a if condition statement if there are less colors.