For loop works until it has to work too much then program stops responding.

[nawilliams]

The bellow macro was created to pull the notes from cells meeting specific criteria. That in mind, the code works perfectly and does exactly what is needed. the issue at hand is that the range the loop is running through can be anywhere from 1 to 10000. the loop can handle search for and pull the notes for around 50 rows but after that it stats to give the application not responding error after processing for sometime. if there is another method that this can be done please help!!

Sub Pull_Lead_Notes()
Dim CurRow As Integer
Dim Found As Variant
Dim LastFound As Variant
Dim ACell As Range
Dim DCell As Range
Dim JCell As Range
Dim NCell As Range
Dim LastRow As Long
Dim LastRow2 As Long
Dim WS1 As Worksheet
Dim WS2 As Worksheet

Set WS1 = Worksheets("Table")
Set WS2 = Worksheets("Agent Access DB")
LastRow = WS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
CurRow = 17

Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For CurRow = 17 To LastRow
Set ACell = WS1.Range("A" & CurRow)
Set DCell = WS1.Range("D" & CurRow)
Set JCell = WS1.Range("J" & CurRow)
Set NCell = WS1.Range("N" & CurRow)

On Error Resume Next
Found = WS2.Columns("D").EntireRow.Find(What:=(DCell.Value), SearchOrder:=xlByRows, SearchDirection:=xlNext).Row
LastFound = WS2.Columns("D").EntireRow.Find(What:=(DCell.Value), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    If Err.Number = 91 Then
        WS1.Range("O" & CurRow).Style = "Bad"
    Else
        WS1.Range("O" & CurRow).Style = "Good"
            If WS2.Range("N" & Found).Value = "" Then
        
            Else
        
            For Found = Found To LastFound
                If WS2.Range("A" & Found).Value = ACell.Value Then
                    If WS2.Range("J" & Found).Value = JCell.Value Then
                        NCell.Value = WS2.Range("N" & Found).Value
                        Exit For
                Else
                    Found = WS2.Columns("D").EntireRow.Find(What:=(DCell.Text), SearchOrder:=xlByRows, SearchDirection:=xlNext, After:=Range("D" & Found)).Row - 1
                
                    End If
                End If
            Next Found
            End If
    End If
Next CurRow

LastRow = WS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
WS1.Range("A17:N" & LastRow).Style = "Normal"
With ActiveSheet
    .ListObjects.Add(xlSrcRange, Range("A16:N" & LastRow), , xlYes).Name = "TTable"
    .Range("TTable[#All]").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlYes
    .ListObjects("TTable").TableStyle = "TableStyleDark9"
    .ListObjects("TTable").Unlist
End With
    LastRow2 = WS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    Range("O" & LastRow2 & ":O" & LastRow + 1).Delete
    Range("A1").Select
    
End Sub

 

[offthelip]

Your probelm is very similar to the the problem which I help with in this thread. You need to start again and use variant arrays, don't use find and avoid accessing the worksheet in a loop. It will also make your code much faster
https://www.mrexcel.com/forum/excel-questions/1100262-code-running-super-slow.html

 

[nawilliams]

avoid accessing the worksheet in a loop. It will also make your code much faster

could you please elaborate on this? what does it mean to access worksheet in a loop?

 

[offthelip]

I have annotated your code with comments to show which line access the worksheet ( practically all of them)

For CurRow = 17 To LastRow  ' This starts the loop
Set ACell = WS1.Range("A" & CurRow) ' This accesses the worksheet
Set DCell = WS1.Range("D" & CurRow) ' This accesses the worksheet
Set JCell = WS1.Range("J" & CurRow) ' This accesses the worksheet
Set NCell = WS1.Range("N" & CurRow) ' This accesses the worksheet


On Error Resume Next
Found = WS2.Columns("D").EntireRow.Find(What:=(DCell.Value), SearchOrder:=xlByRows, SearchDirection:=xlNext).Row ' This accesses the worksheet
LastFound = WS2.Columns("D").EntireRow.Find(What:=(DCell.Value), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' This accesses the worksheet
    If Err.Number = 91 Then
        WS1.Range("O" & CurRow).Style = "Bad" ' This accesses the worksheet
    Else
        WS1.Range("O" & CurRow).Style = "Good" ' This accesses the worksheet
            If WS2.Range("N" & Found).Value = "" Then ' This accesses the worksheet
        
            Else
        
            For Found = Found To LastFound
                If WS2.Range("A" & Found).Value = ACell.Value Then ' This accesses the worksheet
                    If WS2.Range("J" & Found).Value = JCell.Value Then ' This accesses the worksheet
                        NCell.Value = WS2.Range("N" & Found).Value ' This accesses the worksheet
                        Exit For
                Else
                    Found = WS2.Columns("D").EntireRow.Find(What:=(DCell.Text), SearchOrder:=xlByRows, SearchDirection:=xlNext, After:=Range("D" & Found)).Row - 1 ' This accesses the worksheet
                
                    End If
                End If
            Next Found
            End If
    End If
Next CurRow ' this is the end of the loop

To avoid this instead of assigning a range to a variable load the VALUES in the range to a variant array and operate on the variant array. The best way is to load the whole worksheet into an array instead of reassigning four varainbler to a different range every iteration.
As a comparison look at these twobits of code both of which do the same thing, one does it by accessing the worksheet by operating on celsl and the other does by loading the workhset into a variant array and operating on the array, it is over 500 times faster.
I think your memory error is because you are redefining range variables every iteration and probably gobbling up memory. However I could be wrong on the reason it fails but using varinat arrayts is much more efficient and would be very surprised if it doesn't solve the problem.
A "Range" is an extremely complex object is contains lots of information about formatting, values, links all sorts of things. The only bit of a range that you need to deal with is the values. Load these into a variant array and just use those.

Sub slow()
tt = Timer()
'initialise
 For j = 1 To 10
  Cells(j, 1) = 0
 Next j
For i = 1 To 1000
 For j = 1 To 10
  Cells(j, 1) = Cells(j, 1) + 1
 Next j
Next i
MsgBox (Timer() - tt)


End Sub


Sub fast()
tt = Timer()
Dim outarr(1 To 10, 1 To 1)
For k = 1 To 500 ' Notice the extra 1 to 500 loop!!!
'initialise
 For j = 1 To 10
  outarr(j, 1) = 0
 Next j
Range(Cells(1, 1), Cells(10, 1)) = outarr


inarr = Range(Cells(1, 1), Cells(10, 1))
For i = 1 To 1000
 For j = 1 To 10
  inarr(j, 1) = inarr(j, 1) + 1
 Next j
Next i




Range(Cells(1, 1), Cells(10, 1)) = inarr
Next k
MsgBox (Timer() - tt)


End Sub

 

[offthelip]

I have started rewriting your code using variant arrays unfortunatel I ned to go befoer IO have finished but it will hopefully show you how to do it:

Sub Pull_Lead_Notes2()
Dim CurRow As Integer
Dim Found As Variant
Dim LastFound As Variant
Dim ACell As Variant
Dim DCell As Variant
Dim JCell As Variant
Dim NCell As Variant
Dim LastRow As Long
Dim LastRow2 As Long
Dim WS1 As Worksheet
Dim WS2  As Worksheet




Set WS1 = Worksheets("Table")
Set WS2 = Worksheets("Agent Access DB")
LastRow = WS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
WS1arr = WS1.Range(Cells(1, 10), Cells(LastRow, 15)) ' columm O is column 15
CurRow = 17
With Worksheets("Agent Access DB")
LastRow2 = .Cells(Rows.Count, "D").End(xlUp).Row
ws2arr = Worksheets("Agent Access DB").Range(.Cells(1, 10), .Cells(LastRow, 15)) ' columm O is column 15


Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For CurRow = 17 To LastRow  ' This starts the loop
 ACell = WS1arr(CurRow, 1)
 DCell = WS1arr(CurRow, 4)
 JCell = WS1arr(CurRow, 10)
 NCell = WS1arr(CurRow, 14)


On Error Resume Next
For i = 1 To LastRow2
 If DCell = ws2arr(i, 4) Then
  Found = i
 End If
Next i
'Found = WS2.Columns("D").EntireRow.Find(What:=(DCell.Value), SearchOrder:=xlByRows, SearchDirection:=xlNext).Row ' This accesses the worksheet
' this is as far as I have got need to go
LastFound = WS2.Columns("D").EntireRow.Find(What:=(DCell.Value), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' This accesses the worksheet
    If Err.Number = 91 Then
        WS1.Range("O" & CurRow).Style = "Bad" ' This accesses the worksheet
    Else
        WS1.Range("O" & CurRow).Style = "Good" ' This accesses the worksheet
            If WS2.Range("N" & Found).Value = "" Then ' This accesses the worksheet
        
            Else
        
            For Found = Found To LastFound
                If WS2.Range("A" & Found).Value = ACell.Value Then ' This accesses the worksheet
                    If WS2.Range("J" & Found).Value = JCell.Value Then ' This accesses the worksheet
                        NCell.Value = WS2.Range("N" & Found).Value ' This accesses the worksheet
                        Exit For
                Else
                    Found = WS2.Columns("D").EntireRow.Find(What:=(DCell.Text), SearchOrder:=xlByRows, SearchDirection:=xlNext, After:=Range("D" & Found)).Row - 1 ' This accesses the worksheet
                
                    End If
                End If
            Next Found
            End If
    End If
Next CurRow ' thisis the end of the loop


LastRow = WS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
WS1.Range("A17:N" & LastRow).Style = "Normal"
With ActiveSheet
    .ListObjects.Add(xlSrcRange, Range("A16:N" & LastRow), , xlYes).Name = "TTable"
    .Range("TTable[#All]").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlYes
    .ListObjects("TTable").TableStyle = "TableStyleDark9"
    .ListObjects("TTable").Unlist
End With
    LastRow2 = WS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    Range("O" & LastRow2 & ":O" & LastRow + 1).Delete
    Range("A1").Select
    
End Sub

 

[nawilliams]

Ok here is my attempt at variant arrays for the first time! I cant figure out how to reference NCell or OCell to update the cell value/style.

Sub Pull_Lead_Notes()
Dim CurRow As Integer
Dim WS1arr As Variant
Dim WS2arr As Variant
Dim Found As Variant
Dim ACell As Variant
Dim DCell As Variant
Dim JCell As Variant
Dim NCell As Variant
Dim OCell As Variant
Dim LastRow As Long
Dim LastRow2 As Long
Dim WS1 As Worksheet
Dim WS2 As Worksheet

Set WS1 = Worksheets("Table")
Set WS2 = Worksheets("Agent Access DB")

WS1arr = WS1.UsedRange.Value
WS2arr = WS2.UsedRange.Value
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
LastRow = WS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

For CurRow = 17 To LastRow
ACell = WS1arr(CurRow, 1)
DCell = WS1arr(CurRow, 4)
JCell = WS1arr(CurRow, 10)
NCell = WS1arr(CurRow, 14)
OCell = WS1arr(CurRow, 15)


For Found = LBound(WS2arr) To UBound(WS2arr)
    If WS2arr(Found, 4) = DCell And WS2arr(Found, 10) = JCell And WS2arr(Found, 1) = ACell Then
        NCell.Value = WS2arr(Found, 14)
        OCell.Style = "Good"
        Exit For
        
    ElseIf Not WS2arr(Found, 4) = DCell And WS2arr(Found, 10) = JCell And WS2arr(Found, 1) = ACell Then
        OCell.Style = "Bad"
    End If
Next Found
Next CurRow
[COLOR=#00ff00]
' the below function can be disregarded it is working as intended[/COLOR]

WS1.Range("A17:N" & LastRow).Style = "Normal"
With WS1 
    .ListObjects.Add(xlSrcRange, Range("A16:N" & LastRow), , xlYes).Name = "TTable"
    .Range("TTable[#All]").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlYes
    .ListObjects("TTable").TableStyle = "TableStyleDark9"
    .ListObjects("TTable").Unlist
End With
    LastRow2 = WS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    Range("O" & LastRow2 & ":O" & LastRow + 1).Delete
    Range("A1").Select
    
End Sub

 

[offthelip]

Hi I have updated you code to show you how output using variant arrays. Note you can't use variant arrays to chagne the style on a worksheet. This is one of the reasons I always avoid using any formatting to indicate a condition because it it much slower to handle in VBA.

Sub Pull_Lead_Notes()
Dim CurRow As Integer
Dim WS1arr As Variant
Dim WS2arr As Variant
Dim Found As Variant
Dim ACell As Variant
Dim DCell As Variant
Dim JCell As Variant
Dim NCell As Variant
Dim OCell As Variant
Dim LastRow As Long
Dim LastRow2 As Long
Dim WS1 As Worksheet
Dim WS2 As Worksheet


Set WS1 = Worksheets("Table")
Set WS2 = Worksheets("Agent Access DB")


WS1arr = WS1.UsedRange.Value
WS2arr = WS2.UsedRange.Value
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.DisplayAlerts = False
LastRow = WS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
' define an output array for columns 14 and 15 (N and O)
outarr = WS1.Range(Cells(1, 14), Cells(LastRow, 15))
For CurRow = 17 To LastRow
ACell = WS1arr(CurRow, 1)
DCell = WS1arr(CurRow, 4)
JCell = WS1arr(CurRow, 10)
NCell = WS1arr(CurRow, 14) ' we don't need these
OCell = WS1arr(CurRow, 15) ' we dons't need these




For Found = LBound(WS2arr) To UBound(WS2arr)
    If WS2arr(Found, 4) = DCell And WS2arr(Found, 10) = JCell And WS2arr(Found, 1) = ACell Then
        outarr(Found, 1) = WS2arr(Found, 14) ' the column indes is 1 here because the arary just pick up[ 2 columns N and O
        outarr(Found, 2) = "Good"  ' I have written good into the cell because you can't format a variant array this has to done on the worksheet
        ' the way I would do it is with conditional formatting if absolutely necesary, however it is generally best to my way of thinking to use real
        ' flags rather than styles to indicate conditions because they work when you print it regardless of the printer
        ' however if you really need to set the style you can use
         ' ws1.range(cells(found,15),cells(found,15)).style="Good"
        Exit For
        
    ElseIf Not WS2arr(Found, 4) = DCell And WS2arr(Found, 10) = JCell And WS2arr(Found, 1) = ACell Then
        outarr(Found, 2) = "Bad"
        '  OCell.Style = "Bad" see comment above
    End If
Next Found
Next CurRow
' now write the output array back to the worksheet
WS1.Range(Cells(1, 14), Cells(LastRow, 15)) = outarr




' the below function can be disregarded it is working as intended


WS1.Range("A17:N" & LastRow).Style = "Normal"
With WS1
    .ListObjects.Add(xlSrcRange, Range("A16:N" & LastRow), , xlYes).Name = "TTable"
    .Range("TTable[#All]").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14), Header:=xlYes
    .ListObjects("TTable").TableStyle = "TableStyleDark9"
    .ListObjects("TTable").Unlist
End With
    LastRow2 = WS1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
    Range("O" & LastRow2 & ":O" & LastRow + 1).Delete
    Range("A1").Select
    
End Sub