VBA macro cell by cell copy paste

I hope you are doing great.

For my work I made a VBA macro which consist on copy pasting in value the content of a cell if the the cell containt a certain formula.

Please find below an extract of the macro.

Option Explicit

Sub copyPasteValue()

Dim cellContent As String

Dim endRow As Integer
Dim endCol As Integer
Dim r As Integer
Dim c As Integer

Dim activeCellColumn As Integer
Dim activeCellRow As Integer

activeCellColumn = ActiveCell.Column
activeCellRow = ActiveCell.Row


endRow = Cells(Rows.Count, activeCellColumn).End(xlUp).Row
endCol = Cells(activeCellRow, Columns.Count).End(xlToLeft).Column


For c = activeCellColumn To endCol

    For r = activeCellRow To endRow
        
        cellContent = Cells(r, c).Formula
        
        If InStr(1, cellContent, "GetCtData") Then
           Cells(r, c).Copy
           Cells(r, c).PasteSpecial Paste:=xlPasteValues
        End If

    Next

Next

Cells(activeCellRow, activeCellColumn).Select

If ActiveWorkbook.Name = "VALUE.xlsx" Then
    ActiveWorkbook.Save
Else
    ActiveWorkbook.SaveAs Filename:="VALUE"
End If

End Sub

The macro is very slow and can take up to more than 1 hour per sheet for certain work. Does anyone have an idea on how to increase the speed ?

Thank you in advance for your help.

Instead looping over all cells (which is time consuming), I would suggest to use the Find function so Excel looks for the formula:

Sub replaceFunction()
    Const FunctionName = "GetCTData" 
    With ActiveCell.Cells                  ' Consider to specify the worksheet.
        Dim hit As Range
        Set hit = .Find(What:=FunctionName , _
                       LookIn:=xlFormulas2, _
                       LookAt:=xlPart)
        If Not hit Is Nothing Then         ' At least one cell found with formula
            Do
                hit.Value = hit.Value      ' Replace value
                Set hit = .FindNext(hit)   ' Search next cell with formula
            Loop While Not hit Is Nothing  ' ...until no more found.
        End If
    End With
End Sub

It may look a little bit strange, but hit.Value = hit.Value replaces the formula with it's actual value.

Looping to look for "GetCtData" sounds unavoidable but what you should do is avoid the clipboard

I.e. instead of your two lines "...Copy" and "...PasteSpecial", use:

Cells(r, c).Value = Cell(r, c).Value

...which overwrites the cell with its own value

You can also cut out the line that stores the formula in the variable 'cellContent', so the bottom block of code can be re-written as follows:

For c = activeCellColumn To endCol
    For r = activeCellRow To endRow
     
        If InStr(1, Cells(r, c).Formula, "GetCtData") Then
           Cells(r, c).Value = Cells(r, c).Value
        End If

    Next r
Next c

Bypassing the clipboard will save a fair amount of time, and is also less buggy (worth a read on avoiding the clipboard as a general rule)

Formulas To Values

Main

<!-- language: lang-vb -->

Sub FormulasToValues()

    Const FORMULA_IDENTIFIER As String = "GetCtData"

    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    Dim rg As Range: Set rg = ws.UsedRange
    
    Dim rCount As Long: rCount = rg.Rows.Count
    Dim cCount As Long: cCount = rg.Columns.Count
    
    Dim rOffset As Long: rOffset = rg.Row - 1
    Dim cOffset As Long: cOffset = rg.Column - 1
    
    Dim Data(): Data = rg.Formula
    
    Dim drg As Range, c As Long, r As Long, fr As Long, lr As Long, cc As String
    
    For c = 1 To cCount
        cc = GetColumnString(c + cOffset)
        For r = 1 To rCount
            If InStr(Data(r, c), FORMULA_IDENTIFIER) > 0 Then
                If fr = 0 Then fr = r + rOffset
                lr = r + rOffset
            Else
                If fr > 0 Then CombineAndReset drg, fr, ws, lr, cc
            End If
        Next r
        If fr > 0 Then CombineAndReset drg, fr, ws, lr, cc
    Next c
                
    If drg Is Nothing Then
        MsgBox "No formulas containing """ & FORMULA_IDENTIFIER _
            & """ found. No action taken.", vbExclamation
        Exit Sub
    End If
    
    PasteAreasValues drg

    With ws.Parent
        If .Name = "VALUE.xlsx" Then .Save Else .SaveAs Filename:="VALUE"
    End With
   
    MsgBox "Formulas containing """ & FORMULA_IDENTIFIER _
        & """ replaced with values.", vbInformation

End Sub

The Help

<!-- language: lang-vb -->

Function GetColumnString(ByVal ColumnNumber As Long) As String
    Dim Remainder As Long
    Do
        Remainder = (ColumnNumber - 1) Mod 26
        GetColumnString = Chr(Remainder + 65) & GetColumnString
        ColumnNumber = Int((ColumnNumber - Remainder) \ 26)
    Loop Until ColumnNumber = 0
End Function

Sub CombineAndReset( _
        ByRef urg As Range, _
        ByRef fr As Long, _
        ByVal ws As Worksheet, _
        ByVal lr As Long, _
        ByVal cc As String)
    CombineRanges urg, ws.Range(cc & fr & ":" & cc & lr)
    fr = 0
End Sub

Sub CombineRanges(ByRef urg As Range, ByVal arg As Range)
    If urg Is Nothing Then Set urg = arg Else Set urg = Union(urg, arg)
End Sub

Sub PasteAreasValues(ByVal rg As Range)
    Dim arg As Range
    For Each arg In rg.Areas: arg.Value = arg.Value: Next arg
End Sub