Help making code faster

[michaelsmith559]

Original code:

Sub Macro5()

    Dim wsSrc As Worksheet
    Dim i As Long, j As Long, k As Long
    Dim dblValue As Double
   
    Application.ScreenUpdating = False
   
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<-Change to the sheet name where the data resides
   
    With wsSrc
        j = .Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For i = 1 To j
            If i = 1 Then
                k = .Range("V:W").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                'Clear any existing entries
                If k >= 2 Then
                    .Range("V2:W" & k).ClearContents
                    k = .Range("V:W").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                End If
                .Range("V" & k).Offset(1, 0).Value = .Range("E" & k).Value 'Change "A" to correct column
                .Range("W" & k).Offset(1, 0).Value = i
                dblValue = .Range("E" & i).Value 'Change "A" to correct column
            Else
                If .Range("E" & i).Value <> dblValue Then 'Change "A" to correct column
                    k = .Range("V:W").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    .Range("W" & k).Value = i - 1
                    dblValue = .Range("E" & i).Value 'Change "A" to correct column
                    .Range("V" & k).Offset(1, 0).Value = dblValue
                    .Range("W" & k).Offset(1, 0).Value = i
                End If
            End If
        Next i
    End With
   
Call Count_Formula_5_Optimized
   
Application.ScreenUpdating = True

End Sub

I tried using chatgpt to help with writing new code using scripting dictionary and arrays. Here is the code it gave respectively:

Scripting Dictionary Code:

Sub FasterVBAUsingDictionary()
    Dim wsSrc As Worksheet
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") '<-Change to the sheet name where the data resides
   
    ' Dictionary to store unique values and their corresponding row numbers
    Dim valueDict As Object
    Set valueDict = CreateObject("Scripting.Dictionary")
   
    Dim lastRow As Long
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "D").End(xlUp).Row ' Assuming column D for unique values
   
    Dim i As Long
    Dim currentValue As Double
    Dim startRow As Long
    startRow = 2  ' Start from row 2 assuming headers are in row 1
   
    For i = startRow To lastRow
        currentValue = wsSrc.Cells(i, "D").Value
       
        ' Check if the value is already in the dictionary
        If valueDict.Exists(currentValue) Then
            ' If the value exists, update the end row for the value
            valueDict(currentValue) = i
        Else
            ' If the value doesn't exist, add it to the dictionary
            valueDict.Add currentValue, i
        End If
    Next i
   
    ' Clear existing entries in columns R and S
    wsSrc.Range("R2:S" & lastRow).ClearContents
   
    ' Populate columns R and S with the unique values and their corresponding row numbers
    Dim outputRow As Long
    outputRow = 2
   
    For Each currentValue In valueDict.Keys
        wsSrc.Cells(outputRow, "R").Value = currentValue
        wsSrc.Cells(outputRow, "S").Value = valueDict(currentValue)
        outputRow = outputRow + 1
    Next currentValue
   
    ' Clean up and release the dictionary object
    Set valueDict = Nothing
End Sub

Array code:

Sub FasterVBAUsingArray()
    Dim wsSrc As Worksheet
    Set wsSrc = ThisWorkbook.Sheets("Sheet1") ' Change to the sheet name where the data resides
   
    ' Get the data into an array
    Dim dataRange As Range
    Set dataRange = wsSrc.Range("A1:D" & wsSrc.Cells(Rows.Count, 4).End(xlUp).Row) ' Assuming columns A:D for data
    Dim dataArr As Variant
    dataArr = dataRange.Value
   
    ' Dictionary to store unique values and their corresponding row numbers
    Dim valueDict As Object
    Set valueDict = CreateObject("Scripting.Dictionary")
   
    Dim lastRow As Long
    lastRow = UBound(dataArr, 1)
   
    Dim i As Long
    Dim currentValue As Double
    Dim startRow As Long
    startRow = 2  ' Start from row 2 assuming headers are in row 1
   
    For i = startRow To lastRow
        currentValue = dataArr(i, 4) ' Assuming column D for unique values
       
        ' Check if the value is already in the dictionary
        If valueDict.Exists(currentValue) Then
            ' If the value exists, update the end row for the value
            valueDict(currentValue) = i
        Else
            ' If the value doesn't exist, add it to the dictionary
            valueDict.Add currentValue, i
        End If
    Next i
   
    ' Clear existing entries in columns R and S
    wsSrc.Range("R2:S" & lastRow).ClearContents
   
    ' Populate columns R and S with the unique values and their corresponding row numbers
    Dim outputArr() As Variant
    ReDim outputArr(1 To valueDict.Count, 1 To 2)
    Dim outputRow As Long
    outputRow = 1
   
    Dim key As Variant
    For Each key In valueDict.Keys
        outputArr(outputRow, 1) = key
        outputArr(outputRow, 2) = valueDict(key)
        outputRow = outputRow + 1
    Next key
   
    ' Write the output array to the worksheet
    wsSrc.Range("R2").Resize(valueDict.Count, 2).Value = outputArr
   
    ' Clean up and release the dictionary object
    Set valueDict = Nothing
End Sub

I tried both codes but both give errors.

Here is an example of how the data looks before code:

combinations row count.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W	X	Y	Z	AA	AB
1	23	31	51	56	67	Value	Rows	Count		Value	Rows	Count		Value	Rows	Count		Value	Rows	Count		Value	Rows	Count		Value	Rows	Count
2	23	31	51	56	68
3	23	31	51	56	69
4	23	31	51	56	70
5	23	31	51	57	58
6	23	31	51	57	59
7	23	31	51	57	60
8	23	31	51	57	61
9	23	31	51	57	62
10	23	31	51	57	63
11	23	31	51	57	64
12	23	31	51	57	65
Sheet1

After code:

Combinations Count Results.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U	V	W
1	Value	Rows	Count		Value	Rows	Count		Value	Rows	Count		Value	Rows	Count		Value	Rows	Count		Value	Rows	Count
2	18	1			33	1			52	1			66	1			68	1				526879	1
3		66870	66870			825	825			9	9			3	3			1	1		66	526880
4	19	66871			34	826			53	10			67	4			69	2				526880	1
5		316770	249900			7965	7140			145	136			6	3			2	1		67	526881
6	20	316771			35	7966			54	146			68	7			70	3				526881	1
7		547070	230300			14510	6545			265	120			8	2			3	1		68	526882
8	21	547071			36	14511			55	266			69	9			68	4				526882	1
9		758946	211876			20494	5984			370	105			9	1			4	1		69	526883
10	22	758947			37	20495			56	371			54	10			69	5				526883	1
11		953526	194580			25950	5456			461	91			25	16			5	1		70	526884
12	23	953527			38	25951			57	462			55	26			70	6				526884	1
13		1048576	95050			30910	4960			539	78			40	15			6	1		63	526885
14					39	30911			58	540			56	41			69	7				526885	1
15						35405	4495			605	66			54	14			7	1		64	526886
16					40	35406			59	606			57	55			70	8				526886	1
J

Cell Formulas
Range	Formula
C3,W16,S15,O15,K15,G15,W14,S13,O13,K13,G13,C13,W12,S11,O11,K11,G11,C11,W10,S9,O9,K9,G9,C9,W8,S7,O7,K7,G7,C7,W6,S5,O5,K5,G5,C5,W4,S3,O3,K3,G3	C3	=(B3-B2)+1

 

[michaelsmith559]

The last part has been copied to a new workbook. The code should output results from f2:ab1048576

 

[Logit]

9 quick tips to improve your VBA macro performance

Mark Johnson
MICROSOFT
‎03-20-2018 08:59 AM - edited ‎11-30-2018 07:35 AM
As part of our work to help enterprises upgrade to Office 365 ProPlus, we have found that some users have been experiencing slow running VBA, which can be frustrating. The good news is that there are steps which can be taken to improve performance.
This post aims to raise awareness of the steps that you can take to improve the performance of your macros, whether you are an end user, IT admin, or developer. We’ve collected the following steps from blog posts, Microsoft field engineers, and Microsoft MVPs like Charles Williams and Jan Karel Pieterse.
1. Turn off everything but the essentials in VBA
One of the first things to do when speeding up VBA code is to turn off unnecessary features such as animations, screen updating, automatic calculations and events while your macro is running. These features can add extra overhead and slow down the macro, particularly if the macro is modifying many cells and triggering lots of screen updates and recalculations.
The below code sample shows you how to enable/disable:
Manual calculations
Screen updates
Animations
Option Explicit
Dim lCalcSave As Long
Dim bScreenUpdate As Boolean
Sub SwitchOff(bSwitchOff As Boolean)
Dim ws As Worksheet
With Application
If bSwitchOff Then
' OFF
lCalcSave = .Calculation
bScreenUpdate = .ScreenUpdating
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableAnimations = False
'
' switch off display pagebreaks for all worksheets
'
For Each ws In ActiveWorkbook.Worksheets
ws.DisplayPageBreaks = False
Next ws
Else
' ON
If .Calculation <> lCalcSave And lCalcSave <> 0 Then .Calculation = lCalcSave
.ScreenUpdating = bScreenUpdate
.EnableAnimations = True
End If
End With
End Sub
Sub Main()
SwitchOff(True) ‘ turn off these features
MyFunction() ‘ do your processing here
SwitchOff(False) ‘ turn these features back on
End Sub
2. Disabling Office animations through system settings
Animations can be disabled across Windows by accessing the Ease of Access Center.
Animations can be disabled in Excel specifically, under the Advanced or Ease of Accesstab, within the File > Options menu.
Please see the following link for more information: https://support.office.com/en-us/article/turn-off-office-animations-9ee5c4d2-d144-4fd2-b670-22cef9fa...
3. Disabling Office animations through registry settings
Office animations can be disabled across multiple computers by setting the appropriate registry key via a group policy setting.
HIVE: HKEY_CURRENT_USER
Key Path: Software\Microsoft\Office\16.0\Common\Graphics
Key Name: DisableAnimations
Value type: REG_DWORD
Value data: 0x00000001 (1)
Warning: Using Registry Editor incorrectly can cause serious, system-wide problems that may require you to re-install Windows to correct them. Microsoft cannot guarantee that any problems resulting from the use of Registry Editor can be solved. Use this tool at your own risk.
4. Removing unnecessary selects
The select method is common to see in VBA code, however it is often added to the macro where it isn’t needed. Select can trigger cell events such as animations and conditional formatting which slow the macro down, so removing unnecessary selects can significantly speed up your macro.

 

[michaelsmith559]

I also tried this code from chatgpt:

Sub Macro5Optimized()

    Dim wsSrc As Worksheet
    Dim lastRow As Long
    Dim dataArr As Variant
    Dim outputArr() As Variant
    Dim i As Long, j As Long
    Dim currentValue As Double
    Dim outputIndex As Long
    
    Application.ScreenUpdating = False
    
    ' Change to the sheet name where the data resides
    Set wsSrc = ThisWorkbook.Sheets("Sheet1")
    
    ' Find the last row in column A
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
    
    ' Read the data into an array for faster processing
    dataArr = wsSrc.Range("A1:E" & lastRow).Value
    
    ReDim outputArr(1 To lastRow, 1 To 2) ' Output array
    
    ' Initialize variables
    outputIndex = 1
    currentValue = dataArr(1, 5) ' Assuming "E" is the correct column
    
    ' Process the data
    For i = 1 To lastRow
        If dataArr(i, 5) <> currentValue Then ' Assuming "E" is the correct column
            outputArr(outputIndex, 2) = i - 1
            outputIndex = outputIndex + 1
            currentValue = dataArr(i, 5) ' Assuming "E" is the correct column
            outputArr(outputIndex, 1) = currentValue
            outputArr(outputIndex, 2) = i
        End If
    Next i
    
    ' Write the output array to the worksheet
    wsSrc.Range("V2:W" & lastRow).ClearContents
    wsSrc.Range("V2").Resize(UBound(outputArr, 1), 2).Value = outputArr
    
    ' Call the Count_Formula_5_Optimized subroutine
    Count_Formula_5_Optimized
    
    Application.ScreenUpdating = True

End Sub

Sub Count_Formula_5_Optimized()
    ' Add your Count_Formula_5_Optimized code here
    ' ...
End Sub

It's highlighting this line:wsSrc.Range("V2").Resize(UBound(outputArr, 1), 2).Value = outputArrError 1004