Application performance setting to speed up VBA-based data copy

[fbohlandt]

Hi all

I have a large spreadsheet I received from a client (many tabs, Vlookup type formulas etc.). I am running a macro over it for analytical purposes which does not require the spreadsheet to recalculate (it is effectively extracting information from a sheet and copies it to another sheet in the same workbook). I have included the code below to see what performance improvements could be made. I add two lines to the macro to improve performance but it doesn't seem to make much difference:

Application.Calculation = xlManual
Application.ScreenUpdating = False

I have also noticed that manually copying and pasting (value) a single cell from one worksheet to another carries the minutest delay. It is hence possible that the spreadsheet is somewhat overburdened.

Full code below

Sub DataModel()


'***
'* Last update: 21 October 2021
'*
'***


Dim wb As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet, wsValue As Worksheet
Dim rngSource As Range
Dim n As Integer, m As Integer, i As Integer, j As Integer, cnt As Integer


Set wb = ThisWorkbook
With wb
    Set wsSource = .Sheets("Production volumes ")
    Set wsTarget = .Sheets("Target")
    'Set wsValue = .Sheets("Values")
End With


'Application settings
Application.Calculation = xlManual
Application.ScreenUpdating = False


cnt = 1
With wsSource
    Set rngSource = .Range("A3:H23")
    n = rngSource.Rows.Count
    m = rngSource.Columns.Count
    For i = 2 To n
        For j = 2 To m
            If rngSource(i, j) <> "" Then
                cnt = cnt + 1
                    wsTarget.Cells(cnt, 1) = rngSource(1, j) 'Country/company
                    wsTarget.Cells(cnt, 2) = rngSource(i, 1) 'Account
                    wsTarget.Cells(cnt, 3).FormulaR1C1 = _
                        "=""'""&RC[-2]&""' --> '""&RC[-1]&""'""" 'Point-of-View
                    wsTarget.Cells(cnt, 4).FormulaR1C1 = _
                        "=IFERROR(INDEX(Values!R20C2:R777C2,MATCH(Target!RC[-2],Values!R20C3:R777C3,0),1),"""")" 'Cognos Account
                    wsTarget.Cells(cnt, 5) = Chr(39) & Chr(61) & rngSource(i, j).Parent.Name & "!" & rngSource(i, j).Address(RowAbsolute:=True, _
                        ColumnAbsolute:=True) 'Cell Reference
                    wsTarget.Cells(cnt, 6) = Chr(39) & rngSource(i, j).Formula 'Excel Formula
            End If
        Next
    Next
End With


'Do a secondary loop to replace Excel cell reference in Excel Formula with Point-of-View


'Application settings
Application.Calculation = xlAutomatic
Application.ScreenUpdating = False


End Sub

 

[fbohlandt]

P.S. I have been thinking about reading this into an array first before pasting but I don't think this will work for the .FormulaR1C1 statements. Let me know if there is a way

 

[fbohlandt]

I have found a way to reduce this to about a second or two. I use combination of copy/paste arrays and .Filldown.

Option Base 1
Sub DataModel()


'***
'* Last update: 21 October 2021
'*
'***


Dim wb As Workbook
Dim wsSource As Worksheet, wsTarget As Worksheet, wsValue As Worksheet
Dim rngSource As Range
Dim n As Integer, m As Integer, i As Integer, j As Integer, cnt As Integer
Dim Arr1() As Variant, Arr2() As Variant
Dim TArr1() As Variant, TArr2() As Variant


Set wb = ThisWorkbook
With wb
    Set wsSource = .Sheets("Production volumes ")
    Set wsTarget = .Sheets("Target")
    'Set wsValue = .Sheets("Values")
End With


'Application settings
Application.Calculation = xlManual
Application.ScreenUpdating = False


cnt = 0
With wsSource
    Set rngSource = .Range("A3:H23")
    n = rngSource.Rows.Count
    m = rngSource.Columns.Count
    
    For i = 2 To n
        For j = 2 To m
            If rngSource(i, j) <> "" Then
                cnt = cnt + 1
                
                    'Define Arrays
                    ReDim Preserve Arr1(2, cnt)
                    ReDim Preserve Arr2(2, cnt)
                    Arr1(1, cnt) = rngSource(1, j) 'Country/company
                    Arr1(2, cnt) = rngSource(i, 1) 'Account
                    Arr2(1, cnt) = Chr(39) & Chr(61) & rngSource(i, j).Parent.Name & "!" & rngSource(i, j).Address(RowAbsolute:=True, _
                        ColumnAbsolute:=True) 'Cell Reference
                    Arr2(2, cnt) = Chr(39) & rngSource(i, j).Formula 'Excel Formula
            
            End If
        Next
    Next
End With


'Transpose Array
ReDim TArr1(cnt, 2)
ReDim TArr2(cnt, 2)
TArr1 = TransposeArray(Arr1)
TArr2 = TransposeArray(Arr2)


'Copy data to target
With wsTarget
    .Range(.Cells(2, 1), .Cells(cnt + 1, 2)) = TArr1
    .Range(.Cells(2, 5), .Cells(cnt + 1, 6)) = TArr2
    .Cells(2, 3).FormulaR1C1 = _
        "=""'""&RC[-2]&""'""&IF(RC[-1]<>"""","" -->'""&RC[-1]&""'"","""")" 'Point-of-View
    .Cells(2, 4).FormulaR1C1 = _
        "=IFERROR(INDEX(Values!R20C2:R777C2,MATCH(Target!RC[-2],Values!R20C3:R777C3,0),1),"""")" 'Cognos Account
    .Range(.Cells(2, 3), .Cells(cnt + 1, 4)).FillDown
End With


rngTarget1 = TArr1
rngTarget2 = TArr2


'Do a secondary loop to replace Excel cell reference in Excel Formula with Point-of-View


'Application settings
Application.Calculation = xlAutomatic
Application.ScreenUpdating = False


End Sub