I found the following VBA code to sum coloured cells, however I get an unexpected end of statement error in the penultimate line:
Function SumByColor(CellColor As Range, SumRange As Range)
Application.Volatile
Dim ICol As Integer
Dim TCell As Range
ICol = CellColor.Interior.ColorIndex
For Each TCell In SumRange
If ICol = TCell.Interior.ColorIndex Then
SumByColor = SumByColor + TCell.Value
End If
Next TCell
End Function
Sub Count_red()
=SumByColor(AC4,J2:AK1725)
End Sub
Edit: I adjusted the last bit according to your suggestions
Sub Count_red()
Function Count_red() As Double
Count_red = SumByColor([AC4], [J2:A1725])
End Function
End Sub
The new error message when I try to run the code: "Ambiguous name detected: Count_red()"
Sub Count_red()
=SumByColor(AC4,J2:AK1725)
End Sub
Is an assignment to nothing.
Based on the names, I am guessing it is supposed to be
Function Count_red()
Count_red=SumByColor([AC4],[J2:AK1725])
End Function
Related
Scenario: Range is named "Dog" and the named range Dog refers to A1:D4. The active cell is in cell B3, which is within the named range.
Is it possible to get the name of the named range that the active cell is in? ie return the name "Dog"?
Perhaps something like the following, which tests the Intersection of the ActiveCell and each named range.
The On Error Resume Next...On Error GoTo 0 is necessary since Intersect will fail when the ActiveCell and the named range are on different sheets, or if n is not a named range but if it refers to a constant or formula, for example.
Sub test()
Dim n As Name
For Each n In ActiveWorkbook.Names
Dim rng As Range
Set rng = Nothing
On Error Resume Next
Set rng = Intersect(ActiveCell, n.RefersToRange)
On Error GoTo 0
If Not rng Is Nothing Then
Debug.Print n.Name
End If
Next
End Sub
This should be a more robust way...
Sub Test()
MsgBox NamesUsedBy(ActiveCell)
End Sub
Function NamesUsedBy(r As Range)
Dim s$, n
On Error Resume Next
For Each n In ThisWorkbook.Names
If Intersect(r, Evaluate(Mid(n, 2))).Row Then
If Err = 0 Then s = s & ", " & n.Name
End If
Err.Clear
Next
NamesUsedBy = Mid(s, 3)
End Function
There is probably a more elegant way of doing this, but this should work.
Sub test()
Dim currentrange As Range
Dim r As Variant
Set currentrange = ActiveCell
For Each r In ThisWorkbook.Names
If Not Application.Intersect(currentrange, Range(Right(r, InStr(1, r, "$")))) Is Nothing Then
Debug.Print r.Name
End If
Next r
End Sub
I am trying to implement cell counting by coloring with VBA you can check here (>https://learn.microsoft.com/en-us/office/troubleshoot/office-developer/count-cells-number-with-color-using-vba).
Issue is that return me every time Compile error: Expected End Sub and i don't know how to avoid it. Before this lines of code i have 2 End Sub-s which works well.
Sub Color()
Function CountCcolor(range_data As Range, criteria As Range) As Long
Dim datax As Range
Dim xcolor As Long
xcolor = criteria.Interior.ColorIndex
For Each datax In range_data
If datax.Interior.ColorIndex = xcolor Then
CountCcolor = CountCcolor + 1
End If
Next datax
End Function
End Sub
Function and Sub blocks can't be nested like that. Each must be separate, with an opening Sub or Function line, and an End Sub/End Function line enclosing the code.
Sub Color()
...
End Sub
Function CountCcolor(range_data As Range, criteria As Range) As Long
...
End Function
To call CountCcolor within Color:
Sub Color()
...
Dim myCount as Long
myCount = CountCcolor(rng1, rng2)
End Sub
I cannot seem to get this to work.
I want to pass a 2D-array from a subroutine to other subroutines in which a data manipulation should take place.
I am calling below subroutine from a command button on Sheet1. In Module1 I have declared the variables as public. Inside the subroutine ReadData, at the End If statement, InputArray is populated with an array consisting of numbers that the user has marked following the inputbox. After the subroutine ReadData has completed, InputArray is empty.
What is the obvious and blatantly daft thing that am I doing wrong?
** Sheet1**:
Private Sub CommandButton1_Click()
Call ReadData
End Sub
**Module1**:
Option Explicit
Option Base 1
Public MyRange, InputArray As Variant
Sub ReadData()
Set MyRange = Application.InputBox("Mark the data array", Type:=8)
If Not MyRange Is Nothing Then
InputArray = MyRange
End If
End Sub
Populate the array as follows and inspect in the locals window. By using .Value you create a 2D array from the selected sheet range. MyRange I think can be local scope and declared as Range. InputArray should probably be a local scope as well and simply passed as an argument to other subs/functions.
Public InputArray As Variant
Sub ReadData()
Dim MyRange As Range
Set MyRange = Application.InputBox("Mark the data array", Type:=8)
If Not MyRange Is Nothing Then
InputArray = MyRange.Value
Stop '<==Delete me after inspection
End If
End Sub
No need for public variables at all.
option explicit
'** Sheet1**:
Private Sub CommandButton1_Click()
dim InputArray as variant, i as long, j as long
ReadData InputArray
for i = lbound(InputArray, 1) to ubound(InputArray, 1)
for j = lbound(InputArray, 2) to ubound(InputArray, 2)
debug.print InputArray(i, j)
next j
next i
End Sub
'**Module1**:
Option Explicit
Sub ReadData(byref arr as variant)
dim myrange as range
Set MyRange = Application.InputBox("Mark the data array", Type:=8)
If Not MyRange Is Nothing Then
arr = MyRange.value
End If
End Sub
1
4
7
10
2
5
8
11
3
6
9
12
along the lines of #Jeeped 's approach, you could simplify code by turning ReadData() to a Function, as follows:
Sheet1:
Function ReadData() As Variant
On Error Resume Next
ReadData = Application.InputBox("Mark the data array", Type:=8).Value
End Function
Module1:
Option Explicit
Private Sub CommandButton1_Click()
Dim InputArray As Variant
InputArray = ReadData
If IsEmpty(InputArray) Then
MsgBox "not a valid selection", vbCritical
Else
'do your stuff with InputArray
End If
End Sub
or you could have your ReadData() function return a Boolean to flag for a successful range selection :
Sheet1:
Function ReadData(arr As Variant) As Boolean
On Error Resume Next
arr = Application.InputBox("Mark the data array", Type:=8).Value
ReadData = Not IsEmpty(arr)
End Function
Module1:
Option Explicit
Private Sub CommandButton1_Click()
Dim InputArray As Variant
If ReadData(InputArray) Then
'do your stuff with InputArray
Else
MsgBox "not a valid selection", vbCritical
End If
End Sub
I am trying to do a count of all rows that are highlighted and are visible (not hidden). My count formula works but it is still counting hidden rows that also happen to be hidden. How can I count only highlighted and visible rows?
'This function will count how many cells in a given range for a given color and are visible
Function COUNTCELLCOLORSIF(CellRange As Range) As Long
Dim rngCell
Application.Volatile
For Each rngCell In CellRange
If rngCell.Interior.ColorIndex = "36" and rngCell.visible Then
COUNTCELLCOLORSIF = COUNTCELLCOLORSIF + 1
End If
Next rngCell
End Function
Use specialcells(xlcelltypevisible)
Function COUNTCELLCOLORSIF(CellRange As Range) As Long
Dim rngCell
Application.Volatile
For Each rngCell In CellRange.specialcells(xlcelltypevisible)
If rngCell.Interior.ColorIndex = "36" Then
COUNTCELLCOLORSIF = COUNTCELLCOLORSIF + 1
End If
Next rngCell
End Function
Try something like this:
Function COUNTCELLCOLORSIF(CellRange As Range) As Long
Dim rngCell, visibleCells
Application.Volatile
visibleCells = CellRange.SpecialCells(xlCellTypeVisible)
For Each rngCell In visibleCells
If rngCell.Interior.ColorIndex = "36" and rngCell.visible Then
COUNTCELLCOLORSIF = COUNTCELLCOLORSIF + 1
End If
Next rngCell
End Function
I've got a spreadsheet, where I'd like A:A range to be formatted automatically so that characters will show in red and digits stay the same color. The following macro seems to work OK, but I need to manually run it every time I change value in the cell:
Sub Red_text()
Dim i As Integer
Dim MyString As String
MyString = ActiveCell.Value
For i = 1 To Len(MyString)
If IsNumeric(Mid(MyString, i, 1)) = False Then
ActiveCell.Characters(i, 1).Font.Color = RGB(247, 66, 66)
End If
Next i
End Sub
So basically I need to change it into an event macro that will reformat the current cell every time it is edited. And limit this behavior to A:A range.
Any help would be greatly appreciated!!
First a slight change to your macro:
Sub Red_text(r As Range)
Dim i As Integer
Dim MyString As String
MyString = r.Value
For i = 1 To Len(MyString)
If IsNumeric(Mid(MyString, i, 1)) = False Then
r.Characters(i, 1).Font.Color = RGB(247, 66, 66)
End If
Next i
End Sub
and also include the following event macro in the worksheet code area:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range
Set A = Range("A:A")
If Intersect(A, Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
Call Red_text(Target)
Application.EnableEvents = True
End Sub
The event macro detects entries to column A and then applies formatting.
EDIT#1:
The event macro must change to handle more than one cell at a time. Remove the original event macro and use this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim A As Range, rBIG As Range, r As Range
Set A = Range("A:A")
Set rBIG = Intersect(A, Target)
If rBIG Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each r In rBIG
Call Red_text(r)
Next r
Application.EnableEvents = True
End Sub