Code required to run a VBA Macro that runs on all cells in a sheet with values (not on ones without)

margram

New Member
Joined
Jul 6, 2020
Messages
12
Office Version
  1. 365
Platform
  1. Windows
Hello,

I have a macro that copies and pastes conditional formatting into a range of cells on a sheet, then runs some more code on these cells. My issue is that the range is predefined (T11:FZ45) and is subject to change by the user. The predefined range was chosen as a likely maximum amount of cells that would ever have values. However, running my code on all these cells takes about 6-10 seconds and I want to cut this down as there is usually a lot less values then the predefined amount. Therefore, I want this range to be dynamic based on the the last cell that has a value (T11:Last Cell With Value). Is this possible? I'd also like to embed this in my current macro. See below.

Sub Button7_Click()
'~~> Defines last cell for ranges below

'~~> Runs conditional formatting on select cells
Sheets("Sheet1").[A11:A45].Copy: Sheets("Sheet1").[T11:FZ45].PasteSpecial xlPasteFormats
'~~> Places formatting into cell permanently and deletes conditional formatting
Dim mySel As Range, aCell As Range
Set mySel = Sheets("Sheet1").[T11:FZ45]
For Each aCell In mySel
With aCell
.Font.FontStyle = .DisplayFormat.Font.FontStyle
.Interior.Color = .DisplayFormat.Interior.Color
.Font.Strikethrough = .DisplayFormat.Font.Strikethrough
End With
Next aCell

mySel.FormatConditions.Delete

End Sub

Thank you,
 

Some videos you may like

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
Try replacing this part ...
Dim mySel As Range, aCell As Range
Set mySel = Sheets("Sheet1").[T11:FZ45]
For Each aCell In mySel
With aCell
.Font.FontStyle = .DisplayFormat.Font.FontStyle
.Interior.Color = .DisplayFormat.Interior.Color
.Font.Strikethrough = .DisplayFormat.Font.Strikethrough
End With
Next aCell


with this ...
VBA Code:
With Sheets("Sheet1").[T11:FZ45]
    .Font.FontStyle = .DisplayFormat.Font.FontStyle
    .Interior.Color = .DisplayFormat.Interior.Color
    .Font.Strikethrough = .DisplayFormat.Font.Strikethrough
End With
 

margram

New Member
Joined
Jul 6, 2020
Messages
12
Office Version
  1. 365
Platform
  1. Windows
Try replacing this part ...
Dim mySel As Range, aCell As Range
Set mySel = Sheets("Sheet1").[T11:FZ45]
For Each aCell In mySel
With aCell
.Font.FontStyle = .DisplayFormat.Font.FontStyle
.Interior.Color = .DisplayFormat.Interior.Color
.Font.Strikethrough = .DisplayFormat.Font.Strikethrough
End With
Next aCell


with this ...
VBA Code:
With Sheets("Sheet1").[T11:FZ45]
    .Font.FontStyle = .DisplayFormat.Font.FontStyle
    .Interior.Color = .DisplayFormat.Interior.Color
    .Font.Strikethrough = .DisplayFormat.Font.Strikethrough
End With
Thanks GWteB. Oddly the code you suggest colors all the cells in that range black for some reason. Ideally I would have it run on the portion of the sheet that has values instead of the predefined [T11:FZ45], so that the worksheet appears cleaner.
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
My previous code is short hand of your code, so it does exactly the same as your code would, but without the need of a loop.
I obviously have not properly read your requirements (hopefully now I did).
The code below is likely to do what you want. Note the two separate functions used to narrow down the search area, which typically decreases the amount of turns of a loop like this.
In case changes are required, let me know.

VBA Code:
Sub Button7_Click()

    '~~> Defines last cell for ranges below

    Dim raRng As Range, raSearch As Range, raCell As Range, raValue As Range

    '~~> Runs conditional formatting on select cells
    With Sheets("Sheet1")
        Set raRng = .[T11:FZ45]                                         ' << option ONE
'        Set raRng = .Range([T11], LastPopulatedCell(.[T11:FZ45]))      ' << option TWO  (not sure whether this is required)
        .[A11:A45].Copy: raRng.PasteSpecial xlPasteFormats              '    (   /\     choose either one of those to suit)
        Application.CutCopyMode = False
        
        ' narrow down search area
        Set raSearch = .Range(FirstPopulatedCell(raRng), LastPopulatedCell(raRng))
    End With

    ' search for cells containing any value within narrowed down search area
    For Each raCell In raSearch
        If Len(raCell.Value) > 0 Then
            If Not raValue Is Nothing Then
                Set raValue = Application.Union(raValue, raCell)
            Else
                Set raValue = raCell
            End If
        End If
    Next raCell

    '~~> Places formatting into cell permanently and deletes conditional formatting
    With raValue
        .Font.FontStyle = .DisplayFormat.Font.FontStyle
        .Interior.Color = .DisplayFormat.Interior.Color
        .Font.Strikethrough = .DisplayFormat.Font.Strikethrough
    End With
    raRng.FormatConditions.Delete
End Sub

Public Function FirstPopulatedCell(ByVal argRng As Range) As Range
    Dim x As Long, y As Long, rng As Range
    If Not argRng Is Nothing Then
        With argRng
            Set rng = .Parent.Cells(.Row + .Rows.Count - 1, .Column + .Columns.Count - 1)
        End With
        On Error Resume Next
        x = argRng.Find(What:="*", After:=rng, Lookat:=xlPart, LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
        y = argRng.Find(What:="*", After:=rng, Lookat:=xlPart, LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False).Row
        Set FirstPopulatedCell = argRng.Parent.Cells(y, x)
        If Err.Number > 0 Then
            Set FirstPopulatedCell = argRng.Cells(1)
            Err.Clear
        End If
    End If
End Function

Public Function LastPopulatedCell(ByVal argRng As Range) As Range
    Dim x As Long, y As Long
    If Not argRng Is Nothing Then
        On Error Resume Next
        x = argRng.Find(What:="*", After:=argRng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
        y = argRng.Find(What:="*", After:=argRng.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        Set LastPopulatedCell = argRng.Parent.Cells(y, x)
        If Err.Number > 0 Then
            Set LastPopulatedCell = argRng.Cells(1)
            Err.Clear
        End If
    End If
End Function
 

margram

New Member
Joined
Jul 6, 2020
Messages
12
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Wow thanks GWetB. It looks like this code is working for the most part. I can see it copies and pastes the conditional formatting into the cells that have values, however it then immediately deletes the conditional formatting and the formatting it was supposed to leave behind. It looks like the code isn't placing the formatting into the cells permanently before deleting? I've tried troubleshooting it with no luck, do you have any suggestions? Thank you!
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
I can see it copies and pastes the conditional formatting into the cells that have values, however it then immediately deletes the conditional formatting and the formatting it was supposed to leave behind.
I missed that part ... and indeed, my previous approach turned out to be not entirely correct.
We now end up with a loop in which each cell is accessed individually. Oddly it turned out, that assigning the displayed formatting properties directly to the cell properties had no effect. Although monitoring through the Immediate Window showed that the properties had been changed (the direct method), after the macro had been finished it turned out that these changes had not been accepted by Excel at all. So indirect assigning by storing those properties first in local variables was needed. Only the button click procedure has been changed. Note that the separate functions are still needed.
Hopefully this code performs as intended.

VBA Code:
Sub Button7_Click()

    '~~> Defines last cell for ranges below
   
    Dim raRng As Range, raSearch As Range, raCell As Range
    Dim lInterColor As Long, lFontColor As Long, lFontSize As Long
    Dim sFontName As String, sFontStyle As String, bFontStrike As Boolean
   
    Application.ScreenUpdating = False

    '~~> Runs conditional formatting on select cells
    With Sheets("Sheet1")
        Set raRng = .[T11:FZ45]
        .[A11:A45].Copy: raRng.PasteSpecial xlPasteFormats
        Application.CutCopyMode = False

        ' narrow down search area
        Set raSearch = .Range(FirstPopulatedCell(raRng), LastPopulatedCell(raRng))
    End With

    ' search for cells containing any value within narrowed down search area
    For Each raCell In raSearch
        With raCell
            '~~> Places formatting into cell permanently and deletes conditional formatting
            If Len(.Value) > 0 Then
                With .DisplayFormat
                    sFontName = .Font.Name
                    lFontSize = .Font.Size
                    lFontColor = .Font.Color
                    sFontStyle = .Font.FontStyle
                    bFontStrike = .Font.Strikethrough
                    lInterColor = .Interior.Color
                End With
                .Font.Name = sFontName
                .Font.Size = lFontSize
                .Font.Color = lFontSize
                .Font.FontStyle = sFontStyle
                .Font.Strikethrough = bFontStrike
                .Interior.Color = lInterColor
                If lInterColor = &HFFFFFF Then
                    .Interior.Pattern = xlNone
                End If
            End If
        End With
    Next raCell

    raRng.FormatConditions.Delete
    Application.ScreenUpdating = True

End Sub
 

margram

New Member
Joined
Jul 6, 2020
Messages
12
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

Thanks again GWteB. This works wonderfully. Do you know how I could add border as well? Some of my conditional formatting includes borders styles.
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
You are welcome. In the code below borders are now also taken into account.

VBA Code:
Sub Button7_Click()

    '~~> Defines last cell for ranges below
    
    Dim raRng As Range, raSearch As Range, raCell As Range
    Dim lInterColor As Long, lFontColor As Long, lFontSize As Long, i As Long
    Dim sFontName As String, sFontStyle As String, bFontStrike As Boolean
    Dim lbColor As Long, lbColorIndex As Long, lbLineStyle As Long, lbTintAndShade As Variant, lbWeight As Long
    
    Application.ScreenUpdating = False

    '~~> Runs conditional formatting on select cells
    With Sheets("Sheet1")
        Set raRng = .[T11:FZ45]
        .[A11:A45].Copy: raRng.PasteSpecial xlPasteFormats
        Application.CutCopyMode = False

        ' narrow down search area
        Set raSearch = .Range(FirstPopulatedCell(raRng), LastPopulatedCell(raRng))
    End With

    ' search for cells containing any value within narrowed down search area
    For Each raCell In raSearch
        With raCell
            '~~> Places formatting into cell permanently and deletes conditional formatting
            If Len(.Value) > 0 Then

                With .DisplayFormat
                    sFontName = .Font.Name
                    lFontSize = .Font.Size
                    lFontColor = .Font.Color
                    sFontStyle = .Font.FontStyle
                    bFontStrike = .Font.Strikethrough
                    lInterColor = .Interior.Color
                End With
                .Font.Name = sFontName
                .Font.Size = lFontSize
                .Font.Color = lFontSize
                .Font.FontStyle = sFontStyle
                .Font.Strikethrough = bFontStrike
                .Interior.Color = lInterColor
                If lInterColor = &HFFFFFF Then
                    .Interior.Pattern = xlNone
                End If
                For i = 1 To 6
                    With .DisplayFormat
                        lbColor = .Borders(i).Color
                        lbColorIndex = .Borders(i).ColorIndex
                        lbTintAndShade = .Borders(i).TintAndShade
                        lbWeight = .Borders(i).Weight
                        lbLineStyle = .Borders(i).LineStyle
                    End With
                    .Borders(i).Color = lbColor
                    .Borders(i).ColorIndex = lbColorIndex
                    .Borders(i).TintAndShade = lbTintAndShade
                    .Borders(i).Weight = lbWeight
                    .Borders(i).LineStyle = lbLineStyle
                Next i
            End If
        End With
    Next raCell

    raRng.FormatConditions.Delete
    Application.ScreenUpdating = True

End Sub
 

margram

New Member
Joined
Jul 6, 2020
Messages
12
Office Version
  1. 365
Platform
  1. Windows
Thank you again GWteB. Can we do this with NumberFormat as well? I've tried including it in the folowing code with no success:

START CODE->
If Len(.Value) > 0 Then
With .DisplayFormat
sFontName = .Font.Name
lFontSize = .Font.Size
lFontColor = .Font.Color
sFontStyle = .Font.FontStyle
bFontStrike = .Font.Strikethrough
lInterColor = .Interior.Color
sFormatNumber = .NumberFormat

End With
.Font.Name = sFontName
.Font.Size = lFontSize
.Font.Color = lFontColor
.Font.FontStyle = sFontStyle
.Font.Strikethrough = bFontStrike
.Interior.Color = lInterColor
.NumberFormat = sFormatNumber
If lInterColor = &HFFFFFF Then
.Interior.Pattern = xlNone
End If
End If
<-END CODE
 

GWteB

Well-known Member
Joined
Sep 10, 2010
Messages
1,295
Office Version
  1. 2013
Platform
  1. Windows
Can we do this with NumberFormat as well?
This would be possible but unfortunately it requires a lot of extra code, at least in the version of Excel I use.
This is because the NumberFormat property of the DisplayFormat object is not updated according to what is visible on the screen. This means that the code should determine whether a number format is assigned to the CF of each cell and if that's the case, the code has to do the following regarding that particular CF rule:
- the number format has to be determined;
- the type of rule has to be determined;
- the used formulae and operator have to be determined;
- using the cell's value the resulting condition should be evaluated.
Such an evaluation differs per CF type and that means a lot of coding. No offence, but I am not going to do that.

You can try the code below, but the result is not always predictable. If a number format is assigned to a particular CF rule, it is used unconditionally, regardless of whether the condition is met or not. If you use multiple CF rules with an assigned number format, the order or priority is decisive.

VBA Code:
Sub Button7_Click()

    '~~> Defines last cell for ranges below
   
    Dim raRng As Range, raSearch As Range, raCell As Range
    Dim lInterColor As Long, lFontColor As Long, lFontSize As Long, i As Long
    Dim sFontName As String, sFontStyle As String, bFontStrike As Boolean
    Dim lbColor As Long, lbColorIndex As Long, lbLineStyle As Long, lbTintAndShade As Variant, lbWeight As Long
    Dim sNumberFormat As String
   
    Application.ScreenUpdating = False

    '~~> Runs conditional formatting on select cells
    With Sheets("Sheet1")
        Set raRng = .[T11:FZ45]
        .[A11:A45].Copy: raRng.PasteSpecial xlPasteFormats
        Application.CutCopyMode = False

        ' narrow down search area
        Set raSearch = .Range(FirstPopulatedCell(raRng), LastPopulatedCell(raRng))
    End With

    ' search for cells containing any value within narrowed down search area
    For Each raCell In raSearch
        With raCell
            '~~> Places formatting into cell permanently and deletes conditional formatting
            If Len(.Value) > 0 Then
                sNumberFormat = ""
                For i = 1 To .FormatConditions.Count
                    If Not IsEmpty(.FormatConditions(i).NumberFormat) Then
                        sNumberFormat = .FormatConditions(i).NumberFormat
                        Exit For
                    End If
                Next i
                With .DisplayFormat
                    sFontName = .Font.Name
                    lFontSize = .Font.Size
                    lFontColor = .Font.Color
                    sFontStyle = .Font.FontStyle
                    bFontStrike = .Font.Strikethrough
                    lInterColor = .Interior.Color
                End With
                .Font.Name = sFontName
                .Font.Size = lFontSize
                .Font.Color = lFontSize
                .Font.FontStyle = sFontStyle
                .Font.Strikethrough = bFontStrike
                .Interior.Color = lInterColor
                If lInterColor = &HFFFFFF Then
                    .Interior.Pattern = xlNone
                End If
                For i = 1 To 6
                    With .DisplayFormat
                        lbColor = .Borders(i).Color
                        lbColorIndex = .Borders(i).ColorIndex
                        lbTintAndShade = .Borders(i).TintAndShade
                        lbWeight = .Borders(i).Weight
                        lbLineStyle = .Borders(i).LineStyle
                    End With
                    .Borders(i).Color = lbColor
                    .Borders(i).ColorIndex = lbColorIndex
                    .Borders(i).TintAndShade = lbTintAndShade
                    .Borders(i).Weight = lbWeight
                    .Borders(i).LineStyle = lbLineStyle
                Next i
                If Len(sNumberFormat) > 0 Then
                    .NumberFormatLocal = sNumberFormat
                End If
            End If
        End With
    Next raCell

    raRng.FormatConditions.Delete
    Application.ScreenUpdating = True

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,127,260
Messages
5,623,687
Members
415,983
Latest member
MusicMan

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top