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
Related
I am trying to write a UDF that counts the number of cells that have conditional formatting. I wrote the following sub that works like a charm:
Sub SumCountByConditionalFormat()
Dim cellrngi As Range
Dim cntresi As Long
cntresi = 0
Set cellrngi = Sheets("Sheet3").Range("I2:I81")
For Each i In cellrngi
If i.DisplayFormat.Interior.Color <> 16777215 Then
cntresi = cntresi + 1
End If
Next i
end sub
and I tried to convert it to a UDF with the following code:
Function CountCellsByColor1(rData As Range) As Long
Dim cntRes As Long
Application.Volatile
cntRes = 0
For Each cell In rData
If cell.DisplayFormat.Interior.Color <> 16777215 Then
cntRes = cntRes + 1
End If
Next cell
CountCellsByColor1 = cntRes
End Function
However when I try the UDF i get a #VALUE! returned. I'm really not sure why and any help would be much appreciated.
You can work around the inability to access DisplayFormat in a UDF using Evaluate
Function DFColor(c As Range)
DFColor = c.DisplayFormat.Interior.Color
End Function
Function CountCellsByColor1(rData As Range) As Long
Dim cntRes As Long, clr As Long, cell As Range
cntRes = 0
For Each cell In rData.Cells
'Evaluate the formula string in the context of the
' worksheet hosting rData
clr = rData.Parent.Evaluate("DFColor(" & cell.Address() & ")")
If clr <> 16777215 Then
cntRes = cntRes + 1
End If
Next cell
CountCellsByColor1 = cntRes
End Function
I'm trying to write code to where on each command button press, the current time is put into the first cell in a range. Then on the next button click, the next cell in the range is filled with the current time, and so on. I cant figure out how to cycle through the desired range and place a time value at that cell on each button press.
I have a basic double For loop that goes through the entire range I want and populates all cells with the current time at once. I only want one cell to populate at a time with the current time on each button click, and I cant figure out how for the life of me.
code so far:
Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer
For i = 6 To 115
For j = 3 To 5
Cells(i, j).Value = Time
Next j
Next i
End Sub
I understand it like that
Private Sub CommandButton1_Click()
Dim rg As Range
Set rg = Range("C6:E115")
Dim sngCell As Range
For Each sngCell In rg
If Len(sngCell.Value) = 0 Then
sngCell.Value = Time
Exit For
End If
Next
End Sub
Update:
This solution should be faster but I think it will not be noticeable.
Private Sub CommandButton1_Click()
Dim rg As Range
Set rg = Union(Range("C5"), Range("C6:E115"))
Dim nextCell As Range
Set nextCell = rg.Find("")
If Not nextCell Is Nothing And nextCell.Address <> "$C$5" Then
nextCell.Value = Time
End If
End Sub
this should do the trick:
Option Explicit
Private Sub CommandButton1_Click()
Dim i As Integer, j As Integer
Dim emptyCellFound As Boolean
Dim c As Range
emptyCellFound = False 'not really needed. just for clarity
For i = 6 To 115
For j = 3 To 5
Set c = Cells(i, j)
If c.Value = "" And Not emptyCellFound Then
c.Value = Time
emptyCellFound = True
End If
Next j
Next i
End Sub
This works if any value is applied in any cell below row 114
Private Sub CommandButton1_Click()
On Error Resume Next
[C6:E115].SpecialCells(xlCellTypeBlanks).Cells(1).Value = Time
On Error GoTo 0
End Sub
..without a value below row 114 this works
Private Sub CommandButton1_Click()
On Error GoTo weird
[C6:E115].SpecialCells(xlCellTypeBlanks).Cells(1).Value = Time
Exit Sub
weird:
If [C115].End(xlUp).Row > 6 Then [C115].End(xlUp).Offset(1).Value = Time
On Error GoTo 0
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'm trying to write a macro in Excel to sum by font colour. A colleague has suggested I use this article for help: ExtendOffice. However, it always gives a syntax error, and I'm not sure why.
The code is:
Public Function SumByColor(pRange1 As Range, pRange2 As Range) As Double
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
The only reason you might get an error, is if one of the cells inside pRange1 has a String or some other non-numeric value.
You can modify your code by adding If IsNumeric(rng.Value) Then.
Modifed Code
Public Function SumByColor(pRange1 As Range, pRange2 As Range) As Double
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
If IsNumeric(rng.Value) Then ' <-- the only thing which might give you an error, if you have a String inside one of the cells
xTotal = xTotal + rng.Value
End If
End If
Next rng
SumByColor = xTotal
End Function
How it is being called from a sheet's cell:
Note: if you change the font's color of one of the cells, you will need to refresh the value in the cell by pressing {Enter} on the cell with the formula again.
This works good for me. Maybe you simply called it in the wrong manner.
For example, if I have data on the "D" column with some fonts in it, this code would work for me:
Public Function SumByColor(pRange1 As Range, pRange2 As Range) As Double
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
MsgBox (SumByColor)
End Function
Sub count_colors()
Call SumByColor(Range("D2", "D" & ActiveSheet.UsedRange.Rows.Count), Range("D2"))
End Sub
(I ignored D1 since it's a header for me. You can change to anything you like)
I do have to agree with Rory, however, that using fonts as data separators is not a good idea
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