Coding for counting bold / strikethrough / underline / formatted cells ?

[rjn008]

Good Morning.

I have the attached and wish to possibly count all or some of the cells that are formatted either by being bold, strikethrough, underlined, italic or coloured text / cell?

Is this possible using similar data to below;

Book2
	B	C
6	Alex Tattersley1	Man Utd
7	Alex Tattersley2	Arsenal
8	Ants Farrell (AT)	Man Utd
9	Ben Cummings	Brighton & HA
10	Brandon Wilkinson	Arsenal
11	Chris Knutton (AT)	Man Utd
12	Craig Robbo (G)	Brighton & HA
13	Daniel Cummings	Arsenal
14	Danny Colbeck	Arsenal
15	Dave Crabtree	Newcastle Utd
16	Daz Hodgson	Man City
17	Dean Barrett1	Arsenal
18	Dean Barrett2	Brighton & HA
19	Elliott Kenyon	Brighton & HA
20	Gary Crabtree	Brighton & HA
21	Gavin West	Newcastle Utd
22	Geordie Watson	Man City
23	George Wilkinson (LW)	Man Utd
24	Glen Broadbent	Arsenal
25	Harvey Oakes	Man Utd
26	Jacob Colclough	Man Utd
27	James Pinder	Arsenal
28	Jamie Ballester	Arsenal
29	Joe McAdam	Tottenham
30	Joe Slingsby (AT)	Brighton & HA
Sheet1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
B2:C30	Expression	=ROW(B2)=CurrentRow	text	NO

Cells with Data Validation
Cell	Allow	Criteria
C28:C30	List	=$E$76:$E$96
C26	List	=$E$76:$E$96
C22:C24	List	=$E$76:$E$96
C6:C8	List	=$E$76:$E$96
C11:C12	List	=$E$76:$E$96
C17:C20	List	=$E$76:$E$96
C14:C15	List	=$E$76:$E$96

 

[Jeffrey Mahoney]

Please try this code. I put the results in a cell 2 columns to the right. You can change that location by change OutRng.

Sub CountFormattedCells()
  Dim Cel As Range
  Dim Rng As Range
  Dim OutRng As Range
  Dim Bld As Long
  Dim Ital As Long
  Dim Und As Long
  Dim Strike As Long
  Dim ColTxt As Long
  Dim ColCel As Long
  Dim BG As Boolean
  
  
  Set Rng = Selection
  Set OutRng = Rng.Resize(1, 1).Offset(0, 2)
  
  For Each Cel In Rng
    If Cel.Font.Bold = True Then Bld = Bld + 1
    If Cel.Font.Underline = True Then Und = Und + 1
    If Cel.Font.Strikethrough = True Then Strike = Strike + 1
    If Cel.Font.Italic = True Then Ital = Ital + 1
    With Cel.Font
      If .ColorIndex <> xlAutomatic And .ColorIndex <> 1 Then ColTxt = ColTxt + 1
    End With
    
    With Cel.Interior
      If .Pattern = xlNone And .TintAndShade = 0 And .PatternTintAndShade = 0 Then
        BG = False
      Else
        BG = True
      End If
    End With
    If BG = True Then ColCel = ColCel + 1
    
  Next Cel
  
  OutRng.Offset(0, 0).Value = "Bold:"
  OutRng.Offset(0, 1).Value = Bld
  OutRng.Offset(1, 0).Value = "Italic:"
  OutRng.Offset(1, 1).Value = Ital
  OutRng.Offset(2, 0).Value = "Underline:"
  OutRng.Offset(2, 1).Value = Und
  OutRng.Offset(3, 0).Value = "Strike:"
  OutRng.Offset(3, 1).Value = Strike
  OutRng.Offset(4, 0).Value = "Font Color:"
  OutRng.Offset(4, 1).Value = ColTxt
  OutRng.Offset(5, 0).Value = "BG Color:"
  OutRng.Offset(5, 1).Value = ColCel
  
    
  
End Sub

 

[rjn008]

Thanks for the reply, but I have got this error;

I have probably gone a bit extreme on my example above, if it was to work on the below and count the bold cells and then the strikethrough cells;

Book2
	C	D
4	Name	Week 1
5	Alex Tattersley1	Man Utd
6	Alex Tattersley2	Arsenal
7	Ants Farrell (AT)	Man Utd
8	Ben Cummings	Brighton & HA
9	Brandon Wilkinson	Arsenal
10	Chris Knutton (AT)	Man Utd
11	Craig Robbo (G)	Brighton & HA
12	Daniel Cummings	Arsenal
13	Danny Colbeck	Arsenal
14	Dave Crabtree	Newcastle Utd
15	Daz Hodgson	Man City
16	Dean Barrett1	Arsenal
17	Dean Barrett2	Brighton & HA
18	Elliott Kenyon	Brighton & HA
19	Gary Crabtree	Brighton & HA
20	Gavin West	Newcastle Utd
21	Geordie Watson	Man City
22	George Wilkinson (LW)	Man Utd
23	Glen Broadbent	Arsenal
24	Harvey Oakes	Man Utd
25	Jacob Colclough	Man Utd
26	James Pinder	Arsenal
27	Jamie Ballester	Arsenal
28	Joe McAdam	Tottenham
29	Joe Slingsby (AT)	Brighton & HA
30
31	Bold	24
32	Strikethrough	1
Sheet1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
C4:D29	Expression	=ROW(C4)=CurrentRow	text	NO

Cells with Data Validation
Cell	Allow	Criteria
D27:D29	List	=$E$76:$E$96
D25	List	=$E$76:$E$96
D21:D23	List	=$E$76:$E$96
D5:D7	List	=$E$76:$E$96
D10:D11	List	=$E$76:$E$96
D16:D19	List	=$E$76:$E$96
D13:D14	List	=$E$76:$E$96

With the results above showing 24 and 1? But as per original example if I had italic or underline or coloured cells I would need the results for this count also? Hope you can help further?

 

[MARK858]

Thanks for the reply, but I have got this error;

The top code line shouldn't be there and really you want to paste the code in a regular module

 

[rjn008]

The top code line shouldn't be there and really you want to paste the code in a regular module

I have done that and it just doesn't give me any answers... I am sorry, VBA I aren't the best with

 

[MARK858]

Try...

Sub countBoldStrk()
    Dim myCell As Range
    Dim myBold As Long, myStrk As Long

    myBold = 0
    myStrk = 0
  
    For Each myCell In Range("D5:D29")
        If myCell.Font.Bold Then myBold = myBold + 1
        If myCell.Font.Strikethrough Then myStrk = myStrk + 1
    Next

    Range("D31") = myBold
    Range("D32") = myStrk

End Sub

 

[rjn008]

Try...

Sub countBoldStrk()
    Dim myCell As Range
    Dim myBold As Long, myStrk As Long

    myBold = 0
    myStrk = 0
 
    For Each myCell In Range("D5:D29")
        If myCell.Font.Bold Then myBold = myBold + 1
        If myCell.Font.Strikethrough Then myStrk = myStrk + 1
    Next

    Range("D31") = myBold
    Range("D32") = myStrk

End Sub

How do I apply this? I know to press Alt F11 to open VBA Code Object, I have pasted as below, but when I go back to my sheet, I dont see anything?

 

[Jeffrey Mahoney]

I have done that and it just doesn't give me any answers... I am sorry, VBA I aren't the best with

The code I gave you needs to be put in a Standard Module, not a sheet module. Sorry for the confusion.

 

[MARK858]

How do I apply this? I know to press Alt F11 to open VBA Code Object, I have pasted as below, but when I go back to my sheet, I dont see anything?

Alt + F8, select the macro name (if more than one exists) and click Run or assign the code to a button or shape

 

[rjn008]

The code I gave you needs to be put in a Standard Module, not a sheet module. Sorry for the confusion.

View attachment 97254

@Jeffrey Mahoney I have managed to work this out now how to run on both the coding above... but when i run the original one you sent it opens VBA nd highlights 'End Sub' as below, do you know why?

Alt + F8, select the macro name (if more than one exists) and click Run or assign the code to a button or shape

Hi @MARK858 I have got a button now and it is working as I like, could you advise the logic to be added if I was to format 'Italic' and 'Underline'?