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

[margram]

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,

 

[GWteB]

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 ...

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

 

[margram]

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 ...

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]

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.

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]

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]

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.

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]

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]

You are welcome. In the code below borders are now also taken into account.

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]

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]

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.

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