How to optimise macro 5460

Question

Function GetLastRow(ws As Worksheet) As Long

Dim LastRow As Long

Dim LastCol As Long

Dim RowNum As Long

Dim ColNum As Long



LastRow = 0

LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column



For ColNum = 1 To LastCol

    RowNum = ws.Cells(ws.Rows.Count, ColNum).End(xlUp).Row

    If RowNum > LastRow Then

        LastRow = RowNum

    End If

Next ColNum



GetLastRow = LastRow
```End Function

Sub CheckIfElementAsHighlight()

```vba
Dim wsOriginal As Worksheet

Dim wsMatch As Worksheet

Dim lastRowOriginal As Long

Dim lastRowMatch As Long

Dim lastColOriginal As Long

Dim lastColMatch As Long

Dim analystHeaderOriginal As Range

Dim analystHeaderMatch As Range

Dim analystElement As Range

Dim analystText As String

Dim analystColorOriginal As Long

Dim analystColorMatch As Long

Dim entitlement As Range

Dim foundMatch As Boolean

Dim isExactMatch As Boolean

Dim wsHeaderMatch As Boolean

Dim wsCheckColorOriginal As Long

Dim wsCheckColorMatch As Long



Set wsOriginal = ThisWorkbook.Sheets("Original Data")

Set wsMatch = ThisWorkbook.Sheets("Match Data")



lastRowOriginal = GetLastRow(wsOriginal)

lastRowMatch = GetLastRow(wsMatch)

lastColOriginal = wsOriginal.Cells(1, wsOriginal.Columns.Count).End(xlToLeft).Column

lastColMatch = wsMatch.Cells(1, wsMatch.Columns.Count).End(xlToLeft).Column



' Ensure the number of columns matches

If lastColOriginal <> lastColMatch Then

    MsgBox "Number of columns in Match Data Sheet and Original Data Sheet do not match", vbCritical

    Exit Sub

End If



Set analystHeaderOriginal = wsOriginal.Range(wsOriginal.Cells(1, 1), wsOriginal.Cells(1, lastColOriginal))

Set analystHeaderMatch = wsMatch.Range(wsMatch.Cells(1, 1), wsMatch.Cells(1, lastColMatch))



' Ensure headers match

For i = 1 To lastColOriginal

    If wsOriginal.Cells(1, i).Value <> wsMatch.Cells(1, i).Value Then

        MsgBox "Headers in Match Data Sheet and Original Data Sheet do not match", vbCritical

        Exit Sub

    End If

Next i



' Loop through each analyst header in Match Data Sheet

For Each analyst In analystHeaderMatch

    foundMatch = False

    For Each origHeader In analystHeaderOriginal

        If analyst.Value = origHeader.Value Then

            foundMatch = True

            Exit For

        End If

    Next origHeader


    

    If Not foundMatch Then

        MsgBox "No match found", vbCritical

        Exit Sub

    End If

Next analyst



' Initialize flag as False

foundMatch = False

isExactMatch = False



' Loop through each cell in the analyst's column in Original Data Sheet

For Each entitlement In wsOriginal.Columns("A").Cells

    If entitlement.Value = analystElement.Value Then

        If wsOriginal.Cells(entitlement.Row, wsCheckColorOriginal).Value = wsMatch.Cells(entitlement.Row, wsCheckColorMatch).Value Then

            If wsOriginal.Cells(entitlement.Row, wsCheckColorOriginal).Value = analystElement.Text Then

                isExactMatch = True

            End If

        End If

    End If


    

    ' If there's an exact match, highlight the cell in Match Data Sheet

    If isExactMatch Then

        wsMatch.Cells(entitlement.Row, analystHeaderMatch.Column).Interior.Color = RGB(144, 238, 144) ' Light green for exact match

    ElseIf foundMatch Then

        wsMatch.Cells(entitlement.Row, analystHeaderMatch.Column).Interior.Color = RGB(255, 255, 0) ' Yellow for partial match

    Else

        wsMatch.Cells(entitlement.Row, analystHeaderMatch.Column).Interior.Color = RGB(255, 99, 71) ' Red for no match

    End If

Next entitlement
```End Sub

Answer 1

To optimize your macro, you can make several improvements to enhance its efficiency and readability:

1. Avoid Repeated Calculations: Calculate values like lastColOriginal and lastColMatch once and reuse them.
2. Use With Statements: This reduces the need to repeatedly reference the same object.
3. Optimize Loops: Avoid nested loops where possible and use more efficient methods to find matches.

Here is an optimized version of your macro:

Function GetLastRow(ws As Worksheet) As Long
    Dim LastRow As Long
    Dim LastCol As Long
    Dim RowNum As Long
    Dim ColNum As Long

    LastRow = 0
    LastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column

    For ColNum = 1 To LastCol
        RowNum = ws.Cells(ws.Rows.Count, ColNum).End(xlUp).Row
        If RowNum > LastRow Then
            LastRow = RowNum
        End If
    Next ColNum

    GetLastRow = LastRow
End Function

Sub CheckIfElementAsHighlight()
    Dim wsOriginal As Worksheet
    Dim wsMatch As Worksheet
    Dim lastRowOriginal As Long
    Dim lastRowMatch As Long
    Dim lastColOriginal As Long
    Dim lastColMatch As Long
    Dim analystHeaderOriginal As Range
    Dim analystHeaderMatch As Range
    Dim analystElement As Range
    Dim entitlement As Range
    Dim foundMatch As Boolean
    Dim isExactMatch As Boolean

    Set wsOriginal = ThisWorkbook.Sheets("Original Data")
    Set wsMatch = ThisWorkbook.Sheets("Match Data")

    lastRowOriginal = GetLastRow(wsOriginal)
    lastRowMatch = GetLastRow(wsMatch)
    lastColOriginal = wsOriginal.Cells(1, wsOriginal.Columns.Count).End(xlToLeft).Column
    lastColMatch = wsMatch.Cells(1, wsMatch.Columns.Count).End(xlToLeft).Column

    ' Ensure the number of columns matches
    If lastColOriginal <> lastColMatch Then
        MsgBox "Number of columns in Match Data Sheet and Original Data Sheet do not match", vbCritical
        Exit Sub
    End If

    Set analystHeaderOriginal = wsOriginal.Range(wsOriginal.Cells(1, 1), wsOriginal.Cells(1, lastColOriginal))
    Set analystHeaderMatch = wsMatch.Range(wsMatch.Cells(1, 1), wsMatch.Cells(1, lastColMatch))

    ' Ensure headers match
    For i = 1 To lastColOriginal
        If wsOriginal.Cells(1, i).Value <> wsMatch.Cells(1, i).Value Then
            MsgBox "Headers in Match Data Sheet and Original Data Sheet do not match", vbCritical
            Exit Sub
        End If
    Next i

    ' Loop through each cell in the analyst's column in Original Data Sheet
    For Each entitlement In wsOriginal.Columns("A").Cells
        foundMatch = False
        isExactMatch = False

        For Each analystElement In analystHeaderMatch
            If entitlement.Value = analystElement.Value Then
                foundMatch = True
                If wsOriginal.Cells(entitlement.Row, analystElement.Column).Value = wsMatch.Cells(entitlement.Row, analystElement.Column).Value Then
                    isExactMatch = True
                End If
                Exit For
            End If
        Next analystElement

        ' Highlight the cell in Match Data Sheet
        If isExactMatch Then
            wsMatch.Cells(entitlement.Row, analystElement.Column).Interior.Color = RGB(144, 238, 144) ' Light green for exact match
        ElseIf foundMatch Then
            wsMatch.Cells(entitlement.Row, analystElement.Column).Interior.Color = RGB(255, 255, 0) ' Yellow for partial match
        Else
            wsMatch.Cells(entitlement.Row, analystElement.Column).Interior.Color = RGB(255, 99, 71) ' Red for no match
        End If
    Next entitlement
End Sub

Hope this helps.

This version reduces redundant calculations and improves readability.