none
Help on Performance of VBA Code - Excel Hangs

    Question

  • Dear All,

    Need help with below piece of code, it first searches a Key Word from 1 sheet to sheet 2 containing 10,000 line items, once it finds a match, it copies the cells in the range containing the key word to a new sheet and also range containing in the sheet 2 to new sheet to the end of the line of the 1st range. Now the excel hangs while performing this code for rows in both sheets upto 10,000.

    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_SKILL()
    Dim curAddress, curAddress2 As Variant
    Dim DMD As Variant
    Dim PAR 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_DEMAND").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_PAR").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"
                            PAR = Sheet2.Range(Sheet2.Range(curAddress2), Sheet2.Range(curAddress2).End(xlToRight)).Copy
                            Call INS_map_demand(PAR, 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_PAR").Activate
            Sheet2.Range(curAddress2).Select
            ActiveCell.Offset(1, 0).Select
        Loop
        
        Sheets("M_DEMAND").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_demand(DMD As Variant, FLAG As String)


    Sheets("Map_PAR_DEMAND").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

    Tuesday, May 21, 2019 1:18 PM

All replies

  • If you have 10,000 rows, then you are attempting to loop 100,000,000 times.  It's no wonder that Excel appears to hang. Does your code work if you only have 100 cells on each sheet?

    You might want to explain what you have, and what you want from it, rather than giving code that does not work.


    Tuesday, May 21, 2019 9:35 PM