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
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 count the number of instances of a cell containing all uppercase characters in a user defined range, I've got some code already which loops through and highlights those uppercase cells correctly, but I'm struggling to apply that logic to VBA's Countif function. Here's the code I've got but its giving a mismatch error:
'count instances of all caps
Dim allcaps As Long
allcaps = Application.CountIf(Range(rngCompany.Cells(1, 1), rngCompany.Cells(Lastrow, 1)), UCase(Range(rngCompany.Cells(1, 1), rngCompany.Cells(Lastrow, 1))))
MsgBox "There are " & allcaps & " uppercase company names to review."
The code which is highlighting the cells correctly is:
'Highlight all caps company names for review
With ws
For i = 2 To Lastrow
' checks if cells in company name col are uppercase
If rngCompany.EntireColumn.Cells(i, 1).Value = UCase(rngCompany.EntireColumn.Cells(i, 1).Value) Then
wbk1.Sheets(1).Rows(i).Interior.ColorIndex = 6 '6: Yellow
Else
End If
Next i
End With
Is there a way to make the countif code work in a similar way within the loop? Thanks.
Here is how you can do it:
Function AllCapsCount(Target As Range) As Long
With Target.Parent
AllCapsCount = .Evaluate("=SUMPRODUCT(--EXACT(" & Target.Address & ",UPPER(" & Target.Address & ")))")
End With
End Function
Tim's suggestion of simply adding a counter within the loop was the simplest solution for me, after a long day I'd overlooked that way forward!
Code example for anyone coming across this in future:
AllCapsCount = 0
With ws
For i = 2 To Lastrow
' checks if cells in company name col are uppercase
If rngCompany.EntireColumn.Cells(i, 1).Value = UCase(rngCompany.EntireColumn.Cells(i, 1).Value) Then
wbk1.Sheets(1).Rows(i).Interior.ColorIndex = 6 '6: Yellow
AllCapsCount = AllCapsCount + 1
Else
End If
Next i
End With
Highlight and Count Cells if UCase but no LCase
Sub TESTgetAllCapsRange()
Dim rngCompany As Range
Set rngCompany = Range("A2:E11")
rngCompany.Interior.Color = xlNone
Dim rng As Range: Set rng = getAllCapsRange(rngCompany)
If Not rng Is Nothing Then
rng.Interior.Color = vbYellow
Dim AllCaps As Long: AllCaps = rng.Cells.CountLarge
If AllCaps > 1 Then
MsgBox "There are " & AllCaps _
& " uppercase company names to review."
Else
MsgBox "There is 1 uppercase company name to review."
End If
Else
MsgBox "There are no uppercase company names to review."
End If
End Sub
Function getAllCapsRange(rng As Range) As Range
If Not rng Is Nothing Then
Dim tRng As Range
Dim aRng As Range
Dim cel As Range
For Each aRng In rng.Areas
For Each cel In aRng.Cells
If Not IsError(cel) Then
If containsUCaseButNoLCase(cel.Value) Then
buildRange tRng, cel
End If
End If
Next cel
Next aRng
If Not tRng Is Nothing Then
Set getAllCapsRange = tRng
End If
End If
End Function
Function containsUCaseButNoLCase(ByVal CheckString As String) As Boolean
' Check if there is an upper case character.
If StrComp(CheckString, LCase(CheckString), vbBinaryCompare) <> 0 Then
' Check if there are no lower case characters.
If StrComp(CheckString, UCase(CheckString), vbBinaryCompare) = 0 Then
containsUCaseButNoLCase = True
End If
End If
End Function
Sub buildRange(ByRef BuiltRange As Range, AddRange As Range)
If Not AddRange Is Nothing Then
If Not BuiltRange Is Nothing Then
Set BuiltRange = Union(BuiltRange, AddRange)
Else
Set BuiltRange = AddRange
End If
End If
End Sub
I'm trying to identify duplicate cells in a macro. I'm trying to use macros so I can extract the entire row once the duplicate is identified.
I used this code:
Sub MarkDuplicates()
Dim iWarnColor As Integer
Dim rng As Range
Dim rngCell As Variant
Set rng = Sheets("AllAccounts (12-05-2017)").Range("D1:D1613")
iWarnColor = xlThemeColorAccentz
For Each rngCell In rng.Cells
vVal = rngCell.Text
If (WorksheetFunction.CountIf(rng, vVal) = 1) Then
rngCell.Interior.Pattern = xlNone
Else
rngCell.Interior.ColorIndex = iWarnColor
End If
Next rngCell
End Sub
but it only identified empty cells. At the moment I'm trying to only identify duplicate text and I'll extract them later.
Can you please help me do that?
You don't need to put rng.Cells - the .Cells is implied - just use rng
(^ This is semantics - do whatever you want)
Instead of checking rngCell.Text - try rngCell.Value.
.Text is incredibly slow.
^ Really, based on this, should probably use .Value2 instead of .Value for maximum speeeeeeed!
Of course, if we are that concerned, we would use a variant array, but let's keep it simple.
Also, idk why you use xlThemeColorAccentz and ColorIndex
This may work, but it doesn't work for me - I would just use RGB
You're doing a CountIf on the range which is sort of meh.
As for checking duplicates,
I would recommend using a dictionary for this purpose.
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Your code becomes:
Sub MarkDuplicates()
Dim iWarnColor As Long
Dim rng As Range
Dim rngCell As Variant
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
Set rng = Sheets("AllAccounts (12-05-2017)").Range("D1:D1613")
rng.Interior.ColorIndex = xlNone 'Optionally clear all coloring
iWarnColor = RGB(230, 180, 180) 'Red
For Each rngCell In rng
If rngCell.Value <> "" Then 'Ignore blank cells
If Not dict.Exists(rngCell.Value) Then
dict.Add rngCell.Value, rngCell.Row 'Store the row if we want
Else
rngCell.Interior.Color = iWarnColor
'Optionally color the original cell:
'Sheets("AllAccounts (12-05-2017)").Cells(dict(rngCell.Value), "D").Interior.Color = RGB(180, 230, 180)
End If
End If
Next rngCell
End Sub
Results with optional coloring:
Edit (Not Using Dictionary):
So, you're using a mac - oh wellz.
I didn't mention it before, but you can use conditional formatting to solve this.
Anyway, let's just use a collection.
A collection works a lot like a dictionary, but we typically have to loop through it to determine if a particular Key/Value pair exists.
We can cheat this by trying to get a value for a key that doesn't exist and catch the error - I added a function to simplify this process.
Sub MarkDuplicates()
Dim iWarnColor As Long
Dim rng As Range
Dim rngCell As Variant
Dim Col As New Collection
Set rng = Sheets("AllAccounts (12-05-2017)").Range("D1:D1613")
rng.Interior.ColorIndex = xlNone
iWarnColor = RGB(230, 180, 180)
For Each rngCell In rng
If rngCell.Value <> "" Then 'Ignore blank cells
If Not IsInCollection(Col, rngCell.Value2) Then
Col.Add rngCell.Row, Key:=rngCell.Value2
Else
rngCell.Interior.Color = iWarnColor
'Optionally color the original cell
Sheets("AllAccounts (12-05-2017)").Cells(Col(rngCell.Value2), "D").Interior.Color = RGB(180, 230, 180)
End If
End If
Next rngCell
End Sub
Function IsInCollection(Col As Collection, Val As Variant) As Boolean
On Error Resume Next
Debug.Print (Col(Val))
IsInCollection = (Err.Number = 0)
On Error GoTo 0
End Function
New Results (The Same):
I suppose there are several ways to do this. Here is one.
Option Explicit
Sub FilterAndCopy()
Dim wstSource As Worksheet, _
wstOutput As Worksheet
Dim rngMyData As Range, _
helperRng As Range
Set wstSource = Worksheets("Sheet1")
Set wstOutput = Worksheets("Sheet2")
Application.ScreenUpdating = False
With wstSource
Set rngMyData = .Range("A1:XF" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Set helperRng = rngMyData.Offset(, rngMyData.Columns.Count + 1).Resize(, 1)
With helperRng
.FormulaR1C1 = "=if(countif(C1,RC1)>1,"""",1)"
.Value = .Value
.SpecialCells(xlCellTypeBlanks).EntireRow.Copy Destination:=wstOutput.Cells(1, 1)
.ClearContents
End With
Application.ScreenUpdating = True
End Sub
I just started teaching myself VBA so thanks in advance. Why is this giving me an error? The code searches for the column of dates that are in the future. Then searches in that column for any cells that have a value and colors them yellow.
Thanks!
Sub Macro1()
Dim cell As Range
Dim cell2 As Range
Dim ColumnN As Long
For Each cell In Range("I2:ZZ2")
If cell.Value > Now() Then
'
ColumnN = cell.Column
ColumnL = ConvertToLetter(ColumnN)
MsgBox ColumnL & cell.Row
For Each cell2 In Range("ColumnL:ColumnL")
If Not cell2 Is Empty Then
cell2.Interior.ColorIndex = 6
End If
Next cell2
End If
End Sub()
Function ConvertToLetter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
ConvertToLetter = vArr(0)
End Function
You were almost there!
There's two main problems to fix:
replace:
For Each cell2 In Range("ColumnL:ColumnL")
with
For Each cell2 In Range(ColumnL & ":" & ColumnL)
and
If Not cell2 Is Empty Then
with
If Not IsEmpty(cell2) Then
This should result in the following:
Sub Macro1()
Dim cell As Range
Dim cell2 As Range
Dim ColumnN As Long
Dim ColumnL As String
For Each cell In Range("I2:ZZ2")
If cell.Value > Now() Then
ColumnN = cell.Column
ColumnL = ConvertToLetter(ColumnN)
MsgBox ColumnL & cell.Row
For Each cell2 In Range(ColumnL & ":" & ColumnL)
If Not IsEmpty(cell2) Then
cell2.Interior.ColorIndex = 6
End If
Next cell2
End If
Next cell
End Sub
Function ConvertToLetter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
ConvertToLetter = vArr(0)
End Function
Although it is a little inefficient it gets the job done!
To check if a cell is empty, you need to switch the order of how that's done. Switch your If Not statement to If Not IsEmpty(cell2) Then.
Also, it is highly recommended not to name your variables cell, because this is a close to some "special words" (I forget the technical term) Excel uses. I always just use cel instead.
Sub test()
Dim cel As Range
Dim cel2 As Range
Dim ColumnN As Long
For Each cel In Range("I2:ZZ2")
If cel.Value > Now() Then
ColumnN = cel.Column
' ColumnL = ConvertToLetter(ColumnN)
' MsgBox ColumnL & cell.Row
If Not IsEmpty(cel) Then
cel.Interior.ColorIndex = 6
End If
End If
Next cel
End Sub
Edit: If you notice, I also tweaked your cell2 range. This removed the need to run another macro (which can be a cause of issues sometimes), so you only need the column Number.
Edit2: I removed the "ColumnL" range selection - what is that for? I can add it back in, but wasn't sure why you'd loop through I:ZZ columns, but only have the highlighting in column N.
Edit2:
I tweaked the code, now it's much shorter and should run a bit faster:
Sub Macro2()
Dim cel As Range, rng As Range
Dim lastCol As Long
Application.ScreenUpdating = False
lastCol = Cells(2, 9).End(xlToRight).Column ' Note, this assumes there are NO gaps in the columns from I:ZZ
'lastCol = cells(2,16384).End(xltoleft).column ' use this instead, if there are gaps in I2:ZZ2
Set rng = Range(Cells(2, 9), Cells(2, lastCol))
For Each cel In rng
If cel.Value > Now() Then
cel.Interior.ColorIndex = 6
End If
Next cel
Application.ScreenUpdating = True
End Sub
the combination of this sub in a module
Sub hithere3()
Dim Rng As Range
Dim Unique As Boolean
For Each Rng In Worksheets("Sheet8").Range("FS3:FS30") 'for each cell in your B1 to B30 range, sheet1
Unique = True 'we'll assume it's unique
Lastunique = Worksheets("TRADES").Range("C:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 3 To Lastunique 'for each cell in the unique ID cache
If Rng.Value = Worksheets("TRADES").Cells(i, 3).Value Then 'we check if it is equal
Unique = False 'if yes, it is not unique
End If
Next
If Unique Then Worksheets("TRADES").Cells(Lastunique + 1, 3) = Rng 'adds if it is unique
Next
End Sub
with the loop check in a worksheet change events
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub
works except it only updates when I select one of the cells in FS3:FS33
Can anyone suggest how this can be overcome?
maybe with a workchange change range selection type from below?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range, n As Long
Dim RngB As Range, RngC As Range
If Target.Column = 2 And Target.Count = 1 And Target.Row > 1 Then
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
Set RngB = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
Set RngC = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
ray = Array(RngB, RngC)
For n = 0 To 1
For Each Dn In ray(n)
If Not Dn.Address(0, 0) = "C1" And Not Dn.Value = "" Then
.Item(Dn.Value) = Empty
End If
Next Dn
Next n
Range("C2").Resize(.Count) = Application.Transpose(.Keys)
End With
End If
Use either the worksheet Calculate event or the worksheet Change event:
use Calculate if the range contains formulas
use Change if the cells in the range are changed manually
If Intersect(Target, Range("FS3:FS33")) Is Nothing is the culprit. You must change Range("FS3:FS33") to whatever range you want to affect this change.
Private Sub Worksheet_Change(ByVal Target As Range) '<<delete the "Selection" from the name of event
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub
Finally figured it out, the following code works :
Private Sub Worksheet_calculate()
If Range("FS3:FS33") Is Nothing Then
'Do nothing'
Else
Call hithere3
End If
End Sub