How to replace all Offset formulas with direct cell reference in VBA?

Question

My end goal is to replace about 200,000 =Offset formulas in an Excel sheet with the appropriate direct cell reference with VBA. For example, I have =Offset(Sheet1!A1,Sheet2!B3,Sheet2!G5). B3 in sheet2 contains the number 2 and G5 in sheet2 contains the number 3. The offset formula pulls the number in sheet1 that is 2 rows and 3 columns (C3) away from A1. There are 200,000 of these formulas in the sheet and I would like to use VBA to change every one to =Sheet1!C3 in the example above. Clearly every direct cell reference is different - they're not all C3.

I have the following code right now but it replaces with a hardcoded cell number, which I would like to change to be dynamic.

My code is below:

Sub FindReplaceAll()

Dim sht As Worksheet
Dim cell As Range
Dim fnd As Variant
Dim rplc As Variant

fnd = "Offset*"
rplc = "Sheet1!C3"

For Each sht In ActiveWorkbook.Worksheets
    sht.Cells.Replace what:=fnd, Replacement:=rplc, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    Next sht

End Sub

Answer 1

The solution is tried only with simplest OFFSET formula. For coverting more complex offset formula more tweaking may be needed.

Option Explicit
Sub test()
Dim Xformula As String, Yformula As String
Dim Xref As String, XRow As String, XCol As String
Dim YRow As Long, YCol As Long
Dim ZRow As Long, ZCol As Long
Dim Zsht As String, ZColStr As String
Dim Ws As Worksheet, Cel As Range
Dim tm As Double, Cnt As Long
tm = Timer

Set Ws = ThisWorkbook.ActiveSheet
    Cnt = 0
    For Each Cel In Ws.UsedRange.Cells
    If Mid(Cel.Formula, 2, 6) = "OFFSET" Then
    On Error Resume Next
    Xformula = Cel.Formula
    Xformula = Replace(Xformula, "=OFFSET(", "")
    Xformula = Left(Xformula, Len(Xformula) - 1)
    Xref = Split(Xformula, ",")(0)
    'Debug.Print Xref, Xformula, Cel.Address
    XRow = Split(Xformula, ",")(1)
    XCol = Split(Xformula, ",")(2)
    YRow = Evaluate(XRow)
    YCol = Evaluate(XCol)
        If InStr(1, Xref, "!") > 0 Then
        Zsht = Split(Xref, "!")(0) & "!"
        Else
        Zsht = ""
        End If
    ZRow = Range(Xref).Row + YRow
    ZCol = Range(Xref).Column + YCol
    ZColStr = Split(Cells(1, ZCol).Address, "$")(1)
    Zsht = "=" & Zsht & ZColStr & ZRow
        'The cells contain #REF or could not be converted would me marked Red 
        If Err <> 0 Then
        Cel.Interior.Color = vbRed
        Err.Clear
        On Error GoTo 0
        Else
        Cel.Formula = Zsht
        Cnt = Cnt + 1
        End If
    End If
    Next
 Debug.Print Timer - tm & " Seconds taken to convert " & Cnt & " formulas "
End Sub

Since code is tested with around 1000 offset formula only takes 3 sec. For working with 200 K formula it may be needed to add standard techniques like

Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.ScreenUpdating = False

But since i don't personally prefer it, Another option is to tweak the code to work on selected range only and select a limited range in the sheet at a time and execute.

May try on trial workbook / Worksheet only and feedback.

Edit: Adding Array based solution for faster performance, It could be made somehow more faster by using For Each XVariant in Arr and by eliminating Union(ErrRng,... only if there is no need to mark error cells. It takes around 90 sec (70 sec to calculate and 20 more seconds to replace) to change 300 K Offset formula.

Option Explicit
Sub test()
Dim Xformula As String, Yformula As String
Dim Xref As String, XRow As String, XCol As String
Dim YRow As Long, YCol As Long
Dim ZRow As Long, ZCol As Long
Dim Zsht As String, ZColStr As String
Dim Ws As Worksheet, ErrRng As Range, Xcel As Variant
Dim tm As Double, Cnt As Long, Arr As Variant
Dim Rw As Long, Col As Long, RngRowOffset As Long, RngColOffset As Long
tm = Timer
Set Ws = ThisWorkbook.ActiveSheet
    Cnt = 0
    Arr = Ws.UsedRange.Formula
    RngRowOffset = Ws.UsedRange(1, 1).Row - 1
    RngColOffset = Ws.UsedRange(1, 1).Column - 1
    'Debug.Print RngRowOffset, RngColOffset
    For Rw = 1 To UBound(Arr, 1)
    For Col = 1 To UBound(Arr, 2)
    Xcel = Arr(Rw, Col)
    If Mid(Xcel, 2, 6) = "OFFSET" Then
    On Error Resume Next
    Xformula = Xcel
    Xformula = Replace(Xformula, "=OFFSET(", "")
    Xformula = Left(Xformula, Len(Xformula) - 1)
    Xref = Split(Xformula, ",")(0)
    'Debug.Print Xref, Xformula, Cel.Address
    XRow = Split(Xformula, ",")(1)
    XCol = Split(Xformula, ",")(2)
    YRow = Evaluate(XRow)
    YCol = Evaluate(XCol)
        If InStr(1, Xref, "!") > 0 Then
        Zsht = Split(Xref, "!")(0) & "!"
        Else
        Zsht = ""
        End If
    ZRow = Range(Xref).Row + YRow
    ZCol = Range(Xref).Column + YCol
    ZColStr = Split(Cells(1, ZCol).Address, "$")(1)
    Zsht = "=" & Zsht & ZColStr & ZRow
        'The cells containg #REF or could not be converted would me marked Red
        If Err <> 0 Then
            If ErrRng Is Nothing Then
            Set ErrRng = Cells(Rw + RngRowOffset, Col + RngColOffset)
            Else
            Set ErrRng = Union(ErrRng, Cells(Rw + RngRowOffset, Col + RngColOffset))
            End If
        Err.Clear
        On Error GoTo 0
        Else
        Arr(Rw, Col) = Zsht
        Cnt = Cnt + 1
        End If
    End If
    Next
    Next
Debug.Print Timer - tm & " Seconds taken to Calculate " & Cnt & " formulas "
Ws.UsedRange.Formula = Arr
Debug.Print Timer - tm & " Seconds taken to Repalce formulas "
ErrRng.Interior.Color = vbRed
Debug.Print Timer - tm & " Seconds taken to mark error cells "
End Sub