My data extraction macro runs VERY slowly and it bums me out.

[jmpatrick]

I'm using this code to scan a named range and extract data from rows that contain a "/" in a specific column. The macro works fine but takes roughly 20 seconds to scan about 730 rows. Here's the code:

Sub RunPlanRequests()

    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Sheets("FloorPlanRequests").Visible = True
    Sheets("FloorPlanRequests").Select
    
    Dim MR As Excel.Range
    Dim rngCell As Excel.Range
    Dim rngCount As Long
    Dim ws As Worksheet
    
    Set ws = Sheets("Calendar")
    Set MR = ws.Range("CalendarFloorsOrderNumberColumn")
    
    rngCount = 1
    
    For Each rngCell In MR
        If rngCell.Value Like "*/*" Then
            With Sheets("FloorPlanRequests").Range("A" & rngCount)
               .Value = rngCell.Value
               .Offset(, 1).Resize(, 3).Value = Array(ws.Range("F" & rngCell.Row).Value, ws.Range("AS" & rngCell.Row).Value, ws.Range("B" & rngCell.Row).Value)
            End With
            rngCount = rngCount + 1
        End If
    Next rngCell
    
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
End Sub

 

[mumps]

What range does "CalendarFloorsOrderNumberColumn" refer to?

 

[jmpatrick]

What range does "CalendarFloorsOrderNumberColumn" refer to?

It varies based on how many rows there are. Right now it's R5:R736.

 

[mumps]

Try:

Sub RunPlanRequests()
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Dim MR As Variant, lRow As Long, wsCal As Worksheet, i As Long, desWS As Worksheet, rCnt As Long: rCnt = 1
    Sheets("FloorPlanRequests").Visible = True
    Set desWS = Sheets("FloorPlanRequests")
    Set wsCal = Sheets("Calendar")
    With wsCal
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        MR = .Range("B5:B" & lRow).Resize(, 44).Value
    End With
    For i = LBound(MR) To UBound(MR)
        If MR(i, 17) Like "*/*" Then
            With desWS
                .Range("A" & rCnt).Resize(, 4).Value = Array(MR(i, 17), MR(i, 5), MR(i, 44), MR(i, 1))
                rCnt = rCnt + 1
            End With
        End If
    Next i
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

 

[jmpatrick]

Try:

Sub RunPlanRequests()
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    Dim MR As Variant, lRow As Long, wsCal As Worksheet, i As Long, desWS As Worksheet, rCnt As Long: rCnt = 1
    Sheets("FloorPlanRequests").Visible = True
    Set desWS = Sheets("FloorPlanRequests")
    Set wsCal = Sheets("Calendar")
    With wsCal
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        MR = .Range("B5:B" & lRow).Resize(, 44).Value
    End With
    For i = LBound(MR) To UBound(MR)
        If MR(i, 17) Like "*/*" Then
            With desWS
                .Range("A" & rCnt).Resize(, 4).Value = Array(MR(i, 17), MR(i, 5), MR(i, 44), MR(i, 1))
                rCnt = rCnt + 1
            End With
        End If
    Next i
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

Much better. Now takes about 5 seconds. Thanks.

 

[mumps]

You are very welcome.