Copy cells with part of the text bolded using VBA

[mmetev]

Hello there. I have a sheet where part of the contents of some cell is bold. I want to copy on the values from this sheet to new sheet and keep that specific formatting with a macro.

I am currently using a macro that copies the sheet to new sheet (part of the code: "Act_Sheet.Copy before:=Sheets(a)") and then I am removing all formulas with this script:

 ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value

The thing is that any cells containing text that is partially bold is converted to non-bold text.

So, is there a way to copy only the values but also have that specific formatting?

Thank you for your support.

 

[GWteB]

A working solution for you might be:

Sub mmetev()
    Dim shtSource   As Worksheet
    Dim shtDest     As Worksheet
    Dim r           As Range
    
    Set shtSource = ActiveSheet
    shtSource.Copy After:=shtSource
    Set shtDest = ActiveSheet
    For Each r In shtDest.UsedRange
        If r.HasFormula Then
            r.Value = r.Value
        End If
    Next r
End Sub

 

[mmetev]

A working solution for you might be:

Sub mmetev()
    Dim shtSource   As Worksheet
    Dim shtDest     As Worksheet
    Dim r           As Range
   
    Set shtSource = ActiveSheet
    shtSource.Copy After:=shtSource
    Set shtDest = ActiveSheet
    For Each r In shtDest.UsedRange
        If r.HasFormula Then
            r.Value = r.Value
        End If
    Next r
End Sub

Thanks a lot. Worked like a charm though the script execution is a bit slow as it goes through every single cell so I will test how it handles large files.

 

[Fluff]

Another option would be

Dim Cl As Range

For Each Cl In ActiveSheet.UsedRange.SpecialCells(xlFormulas).Areas
   Cl.Value = Cl.Value
Next Cl

 

[GWteB]

the script execution is a bit slow as it goes through every single cell so I will test how it handles large files.

I'm aware of that, but it's a matter of making choices...
The additions in the code below may provide a little more relief in terms of performance. I've commented out two lines. See what happens if they're included for execution.

Sub mmetev_r2()
    Dim shtSource   As Worksheet
    Dim shtDest     As Worksheet
    Dim r           As Range
    Dim i           As Long
    
    Set shtSource = ActiveSheet
    shtSource.Copy After:=shtSource
    Set shtDest = ActiveSheet
    
    Application.ScreenUpdating = False
    Application.Calculation = False
    Application.EnableEvents = False
    
    For Each r In shtDest.UsedRange
        If r.HasFormula Then
            r.Value = r.Value
        End If
'        i = i + 1
'        If i Mod 10 = 0 Then DoEvents
    Next r
    
    Application.EnableEvents = True
    Application.Calculation = True
    Application.ScreenUpdating = True
End Sub

 

[mmetev]

Another option would be

Dim Cl As Range

For Each Cl In ActiveSheet.UsedRange.SpecialCells(xlFormulas).Areas
   Cl.Value = Cl.Value
Next Cl

This worked even better. I updated my code and deleted some columns with formulas which were not relevant to the end result before applying that part of the script.

 

[Fluff]

Glad we could help & thanks for the feedback.