VBA count color code not working properly with some blank cells - vba

I have the following count color code, which is working fine until the range contains blank cells, for which you have to go in the function line and press enter, then the change into different kind of blank cells it seems, as i spotted the errors and everytime i do the step, the vba code is working again. How can I either correct the vba code so I can step this manual enter process for some blank cells, or is there an code that does the manual process for a certain range automatically?
Public Function SumByColor(pRange1 As Range, pRange2 As Range) As Double
'Update 20140210
Application.Volatile
Dim rng As Range
Dim xTotal As Double
xTotal = 0
For Each rng In pRange1
If rng.Font.Color = pRange2.Font.Color Then
xTotal = xTotal + rng.Value
End If
Next
SumByColor = xTotal
End Function

Your function work for me. I don't know what settings do you have, but try mine modification:
Public Function SumByColor(pRange1 As Range, pRange2 As Range) As Double
'Update 20140210
Application.Volatile
Dim rng As Range
Dim rngSum As Range
For Each rng In pRange1
If rng.Font.Color = pRange2.Font.Color And IsNumeric(rng.Value) Then
If rngSum Is Nothing Then
Set rngSum = rng
Else
Set rngSum = Union(rngSum, rng)
End If
End If
Next
SumByColor = WorksheetFunction.Sum(rngSum)
End Function
There is issue however for both mine and your version. It won't recalculate if you change font color for any cell. You must click Calculate Now in Formulas menu.

Related

Am I using the Columns() property improperly, and if so, is there a good workaround?

I'm currently in the process of solving a
type mismatch error
in a macro I'm writing, and I've written a short subroutine to drill down on the specific issue. This subroutine should loop through all of Column A, entering the numbers 1-10 in rows 1-10.
Sub looptest()
Dim rRange As Range
Dim rCell As Range
Dim i As Integer
Set rRange = ThisWorkbook.Worksheets(1).Columns(1)
i = 0
For Each rCell In rRange
If i < 10 Then
i = i + 1
rCell.Value2 = i
End If
Next rCell
End Sub
Instead this fills every cell in Column A with 1. Stepping through it in debug mode shows that instead of referencing a single cell, rCell references the entire column.
I have found that if I replace
Set rRange = ThisWorkbook.Worksheets(1).Columns(1)
with
Set rRange = ThisWorkbook.Worksheets(1).Range("A1:A100")
the macro works as intended, however I'd prefer to be able to use Columns() or something similar in my production code.
Am I using the Columns() property improperly, and if so, is there a good workaround?
Begin with these changes:
Set rRange = ThisWorkbook.Worksheets(1).Columns(1).Cells
Dim i As Long
Using the .Cells lets us loop over the cells in a column rather than columns in a worksheet.

How do I get a UDF based on cell color to auto update in excel

I found a UDF that calculates the values of a cell based on their color. It worked perfectly the first time that I used it. However, now when I change the color of a cell (the color dictates if the cell has been planned or executed), in the existing workbook it does not auto-update. See code below:
Function SumByColor(CellColor As Range, rRange As Range)
Application.Volatile True
Dim cSum As Long
Dim ColIndex As Integer
Dim cl As Variant
ColIndex = CellColor.Interior.ColorIndex
For Each cl In rRange
If cl.Interior.ColorIndex = ColIndex Then
cSum = WorksheetFunction.Sum(cl, cSum)
End If
Next cl
SumByColor = cSum
End Function
I have tried Application.Volitale, but no luck. F9 works to update the cells that house the function. Though, it would be better to auto-update in case I get busy, or walk away from my WS. Any ideas?
You can create a worksheet event proc that will run when a change is recognized on the sheet:
Private Sub Worksheet_Change(ByVal Target as Range)
'Call function with appropriate variables
End Sub

AutoRefresh Excel VBA

I have a module which I use to check what color the cell contains. If the cell is red, blue or green. But when I use the function: =SumBycolor(cell with colorx;From cell:toCell) it doesn't auto update. I have to open the cell and press enter to make any updates
Anyone have some good tips for how to add auto update?
Function SumByColor(CellColor As Range, rRange As Range)
Dim cSum As Long
Dim ColIndex As Integer
ColIndex = CellColor.Interior.ColorIndex
For Each cl In rRange
If cl.Interior.ColorIndex = ColIndex Then
cSum = WorksheetFunction.Sum(cl, cSum)
End If
Next cl
SumByColor = cSum
ActiveWorkbook.RefreshAll
End Function
If your data is in sheet1 then go to event of that sheet and select Worksheet_SelectionChange and write Sheet1.Calculate. This will calculate the function when ever selection is changed. so you do not have to open the cell and press enter to make any updates. Updates will happen with change in selection.
Paste the following code in sheet code where the formula is kept
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
sheets("data").calculate
End Sub

Excel VBA Copy Cell Color error

I have a simple function to copy the background color of cells with similar contents in different ranges (one range is failRange the other is toColor)
It fails at the line assigning the Interior.Color and the excel debugger gives me no information at all, it just stops. I have separated out ever variable so I can easily see all values using the debugger and they are all set just fine.
Does anyone see the problem???
Function ColorRange(failRange As Range, toColor As Range)
Dim targetCell As Range
Dim failCell As Range
Dim targetValue As String
Dim failValue As String
Dim colorValue As Long
Dim compareResult As Integer
Dim counter As Integer
For Each targetCell In toColor
targetValue = Left(targetCell.Text, 7)
For Each failCell In failRange
failValue = failCell.Text
compareResult = InStr(failValue, targetValue)
If compareResult > 0 Then
colorValue = failCell.Interior.ColorIndex
rem next line causes failure
targetCell.Interior.ColorIndex = colorValue
counter = counter + 1
Exit For
End If
Next failCell
Next targetCell
ColorRange= counter
End Function
A UDF called from a worksheet cell can only return a value to that cell. It cannot affect any cell's format.
If you want to change formats, use a sub.

Use VBA functions and variables in a spreadsheet

I'm new to Excel VBA. I am trying to use a VBA function I found online that enables the user to use goalseek on multiple cells at a time. How do I call the function in a spreadsheet and how do I point to the cells that are supposed to be associated with the variables in the function (e.g. Taddr, Aaddr, gval). Do I have to write the cell values and ranges in the code itself and just run it that way?
Maybe I should redefine the function so that it takes these variables as input, so I can write a formula like =GSeekA(Taddr,Aaddr,gval)
Option Explicit
Sub GSeekA()
Dim ARange As Range, TRange As Range, Aaddr As String, Taddr As String, NumEq As Long, i As Long, j As Long
Dim TSheet As String, ASheet As String, NumRows As Long, NumCols As Long
Dim GVal As Double, Acell As Range, TCell As Range, Orient As String
' Create the following names in the back-solver worksheet:
' Taddr - Cell with the address of the target range
' Aaddr - Cell with the address of the range to be adjusted
' gval - the "goal" value
' To reference ranges on different sheets also add:
' TSheet - Cell with the sheet name of the target range
' ASheet - Cell with the sheet name of the range to be adjusted
Aaddr = Range("aaddr").Value
Taddr = Range("taddr").Value
On Error GoTo NoSheetNames
ASheet = Range("asheet").Value
TSheet = Range("tsheet").Value
NoSheetNames:
On Error GoTo ExitSub
If ASheet = Empty Or TSheet = Empty Then
Set ARange = Range(Aaddr)
Set TRange = Range(Taddr)
Else
Set ARange = Worksheets(ASheet).Range(Aaddr)
Set TRange = Worksheets(TSheet).Range(Taddr)
End If
NumRows = ARange.Rows.Count
NumCols = ARange.Columns.Count
GVal = Range("gval").Value
For j = 1 To NumCols
For i = 1 To NumRows
TRange.Cells(i, j).GoalSeek Goal:=GVal, ChangingCell:=ARange.Cells(i, j)
Next i
Next j
ExitSub:
End Sub
GSeekA is a Subprocedure, not a Function. Subprocedures cannot be called from worksheet cells like Functions can. And you don't want to convert GSeekA into a function. Functions should be used to return values to the cell(s) from which they're called. They shouldn't (and often can't) change other things on the sheet.
You need to run GSeekA as a sub. Now the problem becomes how you get user provided information into the sub. You can use InputBox to prompt the user to enter one piece of information. If you have too many, InputBox becomes cumbersome.
You can create areas in the spreadsheet where the user must enter information, then read from that area. That's how it's set up now. It's reading cells named asheet and tsheet. As long as those named ranges are present, the code works.
Finally, you can create a UserForm that the user will fill out. That's like putting a bunch of InputBoxes on one form.
Update Here's a simple procedure that you can start with and enhance.
Public Sub GSeekA()
Dim rAdjust As Range
Dim rTarget As Range
Dim dGoal As Double
Dim i As Long
'Set these three lines to what you want
Set rAdjust = Sheet1.Range("I2:I322")
Set rTarget = Sheet1.Range("J2:J322")
dGoal = 12.1
For i = 1 To rAdjust.Count
rTarget.Cells(i).GoalSeek dGoal, rAdjust.Cells(i)
Next i
End Sub