Optmize My Code - Excel Hangs with Huge Data

Question

I am running a search key word from 1 list in sheet 1 and trying to find a match in sheet 2, both sheet 1 and sheet 2 is having 3000+ data, my code searches the key item from 1 cell in sheet 2 along 3000+ rows and when finds a match it copies the range containing the key word to a new sheet and also it copies the matching range in the sheet 2. Now this becomes recursive for every line item it makes a exact copy from sheet 1 range to a new sheet and adjacent pastes the range from sheet 2.While doing this, when this data is huge, the excel hangs performing the task. Below is the entire code and i call Match () Sub routine using a button

Function GetText(CellRef As String)
Dim StringLength As Integer
StringLength = Len(CellRef)
For i = 1 To StringLength
If Not (IsNumeric(Mid(CellRef, i, 1))) Then Result = Result & Mid(CellRef, i, 1)
Next i
GetText = Result
End Function

Sub MATCH()
Dim curAddress, curAddress2 As Variant
Dim DMD As Variant
Dim P As Variant
Dim curSkill, curDRoleDesc, curPRoleDesc, curDLoc, curPLoc As String
Dim insert_FLAG As String
Dim tempSKILL As String
Dim multSkill() As String
Dim lContinue As Long

Application.EnableCancelKey = xlErrorHandler
On Error GoTo ErrHandler

Sheets("M_DEM").Activate
Sheet1.Range("A4").Select
Do Until IsEmpty(ActiveCell)
    curAddress = ActiveCell.Offset.Address

    DMD = Range(Range(ActiveCell.Offset.Address), Range(ActiveCell.Offset.Address).End(xlToRight)).Copy

    'curSkill = Replace(ActiveCell.Offset(0, 23), "(", " ", 4)

    curSkill = Trim(Left(ActiveCell.Offset(0, 22), InStr(ActiveCell.Offset(0, 22), "(") - 1))
    curDRoleDesc = ActiveCell.Offset(0, 24)
    curDLoc = ActiveCell.Offset(0, 25)

    Sheets("M_P").Activate
    Sheet2.Range("A2").Select
    Do Until IsEmpty(ActiveCell)
        curAddress2 = ActiveCell.Offset.Address

        tempSKILL = Trim(Replace(Replace(ActiveCell.Offset(0, 22), "(", ""), ")", ""))
        tempSKILL = GetText(tempSKILL)
        curPRoleDesc = ActiveCell.Offset(0, 24)
        curPLoc = ActiveCell.Offset(0, 6)

        multSkill = Split(tempSKILL, ",")
        For i = LBound(multSkill()) To UBound(multSkill())
            insert_FLAG = "N"

            If UCase(Trim(multSkill(i))) = UCase(curSkill) Then

                        DMD = Range(Range(curAddress), Range(curAddress).End(xlToRight)).Copy
                        Call INS_map_demand(DMD, insert_FLAG)

                    insert_FLAG = "S"
                        P = Sheet2.Range(Sheet2.Range(curAddress2), Sheet2.Range(curAddress2).End(xlToRight)).Copy
                        Call INS_map_demand(P, insert_FLAG)

                        Sheet3.Range(ActiveCell.Offset.Address).End(xlToRight).Select
                        ActiveCell.Offset(0, 1) = "1"

                        'If Mapping1.chkbox1 = "Y" Then
                        If curPRoleDesc = curDRoleDesc Then
                            ActiveCell.Offset(0, 2) = "1"
                        Else
                            ActiveCell.Offset(0, 2) = "0"
                        End If
                        'Else
                            'ActiveCell.Offset(0, 2) = "0"
                        'End If


                        If UCase(curDLoc) = UCase(curPLoc) Then
                            ActiveCell.Offset(0, 3) = "1"
                        Else
                            ActiveCell.Offset(0, 3) = "0"
                        End If
           End If
        Next i

        Sheets("M_P").Activate
        Sheet2.Range(curAddress2).Select
        ActiveCell.Offset(1, 0).Select
    Loop

    Sheets("M_DEM").Activate
    Sheet1.Range(curAddress).Select
    ActiveCell.Offset(1, 0).Select
Loop

Application.EnableCancelKey = xlInterrupt
Application.CutCopyMode = False
Application.DisplayAlerts = False

ErrHandler:
    If Err.Number = 18 Then
        lContinue = MsgBox("Do you want to Continue (YES)?" & vbCrLf & _
          "Do you want to QUIT? [Click NO]", _
          Buttons:=vbYesNo)
        If lContinue = vbYes Then
            Resume
        Else
            Application.EnableCancelKey = xlInterrupt
            MsgBox ("Program ended at your request")
            Exit Sub
        End If
    End If


    Application.EnableCancelKey = xlInterrupt

End Sub

Sub INS_map_dem(DMD As Variant, FLAG As String)

Sheets("Map_PD").Activate
Sheet3.Range("A1").Select
Do Until IsEmpty(ActiveCell)
    ActiveCell.Offset(1, 0).Select
Loop

If FLAG = "S" Then
    Sheet3.Range(ActiveCell.Offset(-1, 0).Address).Select
    Do Until IsEmpty(ActiveCell)
        ActiveCell.Offset(0, 1).Select
    Loop
End If

ActiveSheet.Paste

End Sub

The first optimization you can make is avoiding `Select` and `ActiveCell`: see [How to avoid using select in Excel VBA](https://stackoverflow.com/questions/10714251/how-to-avoid-using-select-in-excel-vba) — BigBen, May 21 '19 at 13:58
@Suman Code optimisation Q's are _not_ off-topic here at SO (provided they meet all other criteria), advide to move your Q to CodeReview is inappropriate. However, if you do move it, be sure to follow their guidlines. — chris neilsen, May 22 '19 at 03:52

score 0 · Accepted Answer · answered May 21 '19 at 15:46

I did this for the practice, here's how I would do it:

Sub tgr()

    Dim wb As Workbook:     Set wb = ActiveWorkbook
    Dim wsDEM As Worksheet: Set wsDEM = wb.Worksheets("M_DEM")
    Dim wsP As Worksheet:   Set wsP = wb.Worksheets("M_P")
    Dim wsPD As Worksheet:  Set wsPD = wb.Worksheets("Map_PD")

    Dim aDEM As Variant
    With wsDEM.Range("A4", wsDEM.Cells(wsDEM.Rows.Count, "A").End(xlUp)).Resize(, wsDEM.Range("A4").CurrentRegion.Columns.Count)
        If .Row < 4 Then Exit Sub   'No data
        aDEM = .Value
    End With

    Dim aP As Variant
    With wsP.Range("A2", wsP.Cells(wsP.Rows.Count, "A").End(xlUp)).Resize(, wsP.Range("A2").CurrentRegion.Columns.Count)
        If .Row < 2 Then Exit Sub   'No data
        aP = .Value
    End With

    Dim aResults() As Variant:  ReDim aResults(1 To 65000, 1 To UBound(aDEM, 2) + UBound(aP, 2) + 3)
    Dim ixResult As Long:       ixResult = 0

    Dim vSkill As Variant
    Dim sDEMSkill As String
    Dim ixDEM As Long, ixP As Long, ixCol As Long

    For ixDEM = 1 To UBound(aDEM, 1)
        If (ixDEM - 1) Mod 20 = 0 Then
            DoEvents
            Application.StatusBar = "Processing, " & Format(ixDEM / UBound(aDEM, 1), "0.00%")
        End If

        'Define skill from wsDEM to compare against
        sDEMSkill = Trim(Left(aDEM(ixDEM, 23), InStr(1, aDEM(ixDEM, 23) & "(", "(", vbTextCompare) - 1))

        For ixP = 1 To UBound(aP, 1)
            'Compare each comma-delimited skill from wsP against the DEM Skill to find matches
            'Remove the parentheses and numeric characters from the comma delimited list
            For Each vSkill In Split(GetText(Trim(Replace(Replace(aP(ixP, 23), "(", ""), ")", ""))), ",")

                'Check if the current wsP skill matches the DEM Skill
                If UCase(Trim(vSkill)) = UCase(sDEMSkill) Then
                    'Match found, populate new row for results
                    ixResult = ixResult + 1

                    'Get all columns from both sheets from matching rows
                    For ixCol = 1 To UBound(aDEM, 2) + UBound(aP, 2)
                        Select Case (ixCol > UBound(aDEM, 2))
                            Case True:  aResults(ixResult, ixCol) = aP(ixP, ixCol - UBound(aDEM, 2))
                            Case Else:  aResults(ixResult, ixCol) = aDEM(ixDEM, ixCol)
                        End Select
                    Next ixCol

                    'Result col 3rd from end should be: 1
                    aResults(ixResult, UBound(aResults, 2) - 2) = 1

                    'Check if RoleDesc is the same, populate col 2nd from end
                    Select Case (UCase(Trim(aDEM(ixDEM, 25))) = UCase(Trim(aP(ixP, 25))))
                        Case True:  aResults(ixResult, UBound(aResults, 2) - 1) = 1
                        Case Else:  aResults(ixResult, UBound(aResults, 2) - 1) = 0
                    End Select

                    'Check if Loc is the same, populate end col
                    Select Case (UCase(Trim(aDEM(ixDEM, 26))) = UCase(Trim(aP(ixP, 7))))
                        Case True:  aResults(ixResult, UBound(aResults, 2)) = 1
                        Case Else:  aResults(ixResult, UBound(aResults, 2)) = 0
                    End Select

                    If ixResult = UBound(aResults, 1) Then OutputResults wsPD, aResults, ixResult
                End If
            Next vSkill
        Next ixP
    Next ixDEM

    'If matches were found, output results
    If ixResult > 0 Then OutputResults wsPD, aResults, ixResult
    Application.StatusBar = vbNullString

End Sub

Function GetText(ByVal arg_sText As String) As String

    Dim sTemp As String
    Dim sResult As String
    Dim i As Long

    For i = 1 To Len(arg_sText)
        sTemp = Mid(arg_sText, i, 1)
        If Not (IsNumeric(sTemp)) Then sResult = sResult & sTemp
    Next i

    GetText = sResult

End Function

Sub OutputResults(ByRef arg_ws As Worksheet, ByRef arg_aResults As Variant, arg_ixResult As Long)

    Static wsDest As Worksheet
    If wsDest Is Nothing Then Set wsDest = arg_ws

    'Check if results will exceed the number of rows available on the output sheet
    If (wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Row + 1 + arg_ixResult) > wsDest.Rows.Count Then
        'Rows exceeded, create new output sheet to continue on
        Set wsDest = wsDest.Parent.Worksheets.Add(After:=wsDest)
    End If

    'Output currently stored results
    wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).Offset(1).Resize(arg_ixResult, UBound(arg_aResults, 2)).Value = arg_aResults

    Dim lRowMax As Long:    lRowMax = UBound(arg_aResults, 1)
    Dim lColMax As Long:    lColMax = UBound(arg_aResults, 2)

    Erase arg_aResults
    ReDim arg_aResults(1 To lRowMax, 1 To lColMax)
    arg_ixResult = 0

End Sub

Thank you, this helped a lot, i want to add other checks based on check box from a userform, how will i select the case or i add other checks. pls suggest — Suman Saha, May 23 '19 at 17:48

Optmize My Code - Excel Hangs with Huge Data

1 Answers1