VBA script too slow - Checks for duplicate school enrollments and keeps more recent enrollment I have over 260k lines of data. This code is likely to take more than 30hrs to run. Would like help to speed this up. Or is there a way to use something else like PowerQuery to accomplish this? I am very new so please break it down clearly. 

There are 260k rows of student achievement data. Some students may have multiple lines with the same school, meaning that they have math, reading, science achievement at one school (3 rows of data, 1 student, 1 school). But then if they transfer schools, they will have two groups of data (1 student, 2 schools). I need to keep only the information for the most recent school. I want to delete based on date. 



Sub RecentEnrollment()


Dim lrow As Long, lcol As Long, frow As Long
Dim i As Integer, r As Long, c As Long
Dim num As Long, pos As Long
Dim myrng As Variant
Dim namerng As Variant
Dim schrange As Variant
Dim RowFirst As Double, _
    RowLast As Double ' Double is used here to handle the large number of 
            'rows. Integer and Long are small Bit sizes.

Application.ScreenUpdating = False

With Worksheets(1)
    'Find the last non-blank cell in Column "Student ID"
    lrow = .Cells(Rows.Count, 1).End(xlUp).Row
    lcol = .Cells(1, Columns.Count).End(xlToLeft).Column

    MsgBox "Last Row: " &amp; lrow

    'Define the range to search for duplicates. myrng is student id-name 
    'combos and schrange is studentID-sch combos. You may need to change the 
    'sheet name.

For r = 2 To lrow

    'Define the range for the studentId-Name column to search for number of 
    'times each appears 'num and it's position in the list 'pos

    Set namerng = .Range(Cells(r, 5), Cells(lrow, 5))

   'Find the first instance of the student name in the file

    RowFirst = .Cells.Find(What:=.Cells(r, 2), LookAt:=xlWhole,SearchDirection:=xlNext, MatchCase:=False).Row

   'Find the last instance of the student name in the file

    RowLast = .Cells.Find(What:=.Cells(r, 2), LookAt:=xlWhole, SearchDirection:=xlPrevious, MatchCase:=False).Row

    Set myrng = .Range(Cells(RowFirst, 5), Cells(RowLast, 5))
    Set schrange = .Range(Cells(RowFirst, 3), Cells(RowLast, 3))

For c = 1 To 12
    If Application.WorksheetFunction.CountIf(myrng, Cells(r, 5).Value) &gt;= 1 Then
     'How many times does the student name-school combo appear?
      schs = Application.WorksheetFunction.CountIf(schrange, Cells(r, 3).Value)

     'How many times does the student name appear in the file?
      num = Application.WorksheetFunction.CountIf(myrng, Cells(r, 5).Value)

     'What is the position of this student record relative to the duplicated 
      records
      pos = Application.WorksheetFunction.CountIf(namerng, Cells(r, 5).Value)

      'For every student record, print the most recent exit date for all 
      enrollments
        MaxDate = WorksheetFunction.Max(.Range(.Cells(RowFirst, 9), .Cells(RowLast, 9)))
        Cells(r, 10) = MaxDate

    Else
        'Print most recent exit date
            Cells(r, 10) = MaxDate

    End If

        If num &gt; schs Then

            If Cells(r, 9) = MaxDate Then

                Cells(r, 11) = "Keep"

            Else

                Cells(r, 11) = "Delete"

        End If

    End If

    Cells(r, 24) = Time
Next c

Next r

End With
Application.ScreenUpdating = True

End Sub
I had some difficulty in getting your code to run. There are a few variables that weren't defined (see comment #1 below). Additionally, you're working With Worksheets(1), but there are places where you're referencing Cells instead of .Cells. The former references whatever sheet is currently active, whereas the latter directly references Worksheets(1). This can be a subtle source of many problems, and it's something to watch out for.

Your current solution using Find , CountIf, and Max relies heavily on Excel worksheet functions and interactions with the data directly on the worksheet. With larger data sets, this can be a big source of the slowness in your code.

I'm suggesting a different approach which converts the entire student data range to a memory-based array and works from there. Working completely out of memory is much quicker and side-steps the need for Excel access individual cells and ranges.

So, a few comments on your code and implementation:


Please use Option Explicit in all your VBA code. It will help keep your sanity longer.
Declare your variables close to where you're first using them. It's easier to see exactly what you intend by the variable at that point.
Read up on using memory-based arrays in VBA. 


I've split the solution into two parts: setup and execution. The setup routine determines the area of data to be used -- in this case it's the range studentData.

 Option Explicit

Sub ProcessStudentRecords()
    Dim studentWS As Worksheet
    Set studentWS = ThisWorkbook.Sheets("Sheet1")

    Dim lastRow As Long
    Dim lastCol As Long
    With studentWS
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    Dim studentData As Range
    Set studentData = studentWS.Range("A2").Resize(lastRow - 1, lastCol)

    Dim filteredStudents As Variant
    filteredStudents = FilterForRecentEnrollment(studentData)

    '--- now set our destination... 
    Dim destinationWS As Worksheet
    Set destinationWS = ThisWorkbook.Sheets("Filtered")

    '--- ... and define the range where it's going to the correct size
    Dim destRange As Range
    Set destRange = destinationWS.Range("A2").Resize(UBound(filteredStudents, 1), UBound(filteredStudents, 2))

    '--- copy the filtered results to the range and we're done
    destRange = filteredStudents
End Sub


You can see that after the student data is filtered, the function returns a memory-based array. It's a simple couple of steps to write that data back to a worksheet range.

The function FilterForRecentEnrollment does all the heavy lifting by copying your original data into the memory-based array. Your data is large (at 260,000+ rows), but this should still be quicker than relying on Excel moving data directly in and out of the cells.

Moving the data into a memory-based array is quick and easy:

    '--- work with the student data in a memory array for speed
    Dim studentData As Variant
    studentData = studentRange


A Dictionary in VBA is an object that actively manages large amounts of data and you to very quickly access any item in the collection with a unique Key. A key is simply a string. You create the key by using information from your data either a single unique field or a combination of fields that will be unique. As best as I could tell, a "unique" identifier for your data is a combination of the Student ID and the Student Name. Using a key made from these fields, you can test if that entry already exists (and then test the dates).

So, in order to save data in the dictionary, we'll create a simple data-only class called StudentInfo. In your VBA Editor, right-click in the VBA Project "tree" where you see the Microsoft Excel Objects and Modules, then select "Insert-->Class Module". In the Properties window, name the class StudentInfo. This class looks like this:

'--- Class Module:  StudentInfo
Option Explicit

'--- ideally, these should be properties
Public SchoolName As String
Public StudentID As String
Public IDWithSchool As String
Public Student As String
Public IDWithName As String
Public Level As String
Public Grade As String
Public Status As String
Public Exited As Date

Public Property Get NumberOfFields() As Long
    NumberOfFields = 9
End Property


So what we'll do in the Filter routine is to scan a row of your student data, capture all the information into an StudentInfo object, and store it in the Dictionary. Of course, we'll only store the latest exit date of info in the dictionary. It looks like this:

Set rowInfo = New StudentInfo
rowInfo.SchoolName = studentData(i, 1)
rowInfo.StudentID = studentData(i, 2)
rowInfo.IDWithSchool = studentData(i, 3)
rowInfo.Student = studentData(i, 4)
rowInfo.IDWithName = studentData(i, 5)
rowInfo.Level = studentData(i, 6)
rowInfo.Grade = studentData(i, 7)
rowInfo.Status = studentData(i, 8)
rowInfo.Exited = studentData(i, 9)

'--- create a key value that is a unique combination of values that defines
'    a single (non-duplicate) entry
Dim dictionaryKey As String
dictionaryKey = rowInfo.StudentID &amp; rowInfo.Student
If Not students.Exists(dictionaryKey) Then
    students.Add dictionaryKey, rowInfo
Else
    '--- this entry exists, but which has a later exit date?
    Dim existingInfo As StudentInfo
    Set existingInfo = students(dictionaryKey)
    If rowInfo.Exited &gt; existingInfo.Exited Then
        '--- the new row's exit date is later than the existing row,
        '    so replace it
        Set students(dictionaryKey) = rowInfo
    Else
        '--- keep the existing info and ignore the current row
    End If
End If


All that code is inside a loop to catch all the student information and filter it.

Now that we have a collection (Dictionary) of filtered student data, we know exactly how many rows and columns in the data. So we can create a memory-based array and copy the data into that. Again, we're working directly in memory, so it's much faster than working with the sheet for large amounts of data.

'--- now that we have the filtered student data, we'll create an array
'    to return the data
Dim filteredData() As Variant
ReDim filteredData(1 To students.Count, 1 To rowInfo.NumberOfFields)

'--- now populate!
Dim key As Variant
i = 1
For Each key In students.Keys
    Set rowInfo = students(key)
    filteredData(i, 1) = rowInfo.SchoolName
    filteredData(i, 2) = rowInfo.StudentID
    filteredData(i, 3) = rowInfo.IDWithSchool
    filteredData(i, 4) = rowInfo.Student
    filteredData(i, 5) = rowInfo.IDWithName
    filteredData(i, 6) = rowInfo.Level
    filteredData(i, 7) = rowInfo.Grade
    filteredData(i, 8) = rowInfo.Status
    filteredData(i, 9) = rowInfo.Exited
    i = i + 1
Next key


I tested this on the limited sample data you posted and the filtering works. Some decisions you can make would be to adjust the student information you're actually saving in the class and then transferring to the destination. You'll also possibly decide that a different combination of fields is necessary for a unique key. You'll have to determine this based on your real data set.

Here's the full code for the module (don't forget to create the class, as above):

Option Explicit

Sub ProcessStudentRecords()
    Dim studentWS As Worksheet
    Set studentWS = ThisWorkbook.Sheets("Sheet1")

    Dim lastRow As Long
    Dim lastCol As Long
    With studentWS
        lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        lastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    End With
    Dim studentData As Range
    Set studentData = studentWS.Range("A2").Resize(lastRow - 1, lastCol)

    Dim filteredStudents As Variant
    filteredStudents = FilterForRecentEnrollment(studentData)

    '--- now set our destination...
    Dim destinationWS As Worksheet
    Set destinationWS = ThisWorkbook.Sheets("Filtered")

    '--- ... and define the range where it's going to the correct size
    Dim destRange As Range
    Set destRange = destinationWS.Range("A2").Resize(UBound(filteredStudents, 1), UBound(filteredStudents, 2))

    '--- copy the filtered results to the range and we're done
    destRange = filteredStudents
End Sub

Public Function FilterForRecentEnrollment(ByRef studentRange As Range) As Variant
    '--- works through each row in the data range and captures a new
    '    dictionary entry for each new student/school combination.
    '    the value in the dictionary is the information from that row

    '--- work with the student data in a memory array for speed
    Dim studentData As Variant
    studentData = studentRange

    '--- create a dictionary that will help determine if there are duplicates
    Dim students As Scripting.Dictionary
    Set students = New Scripting.Dictionary

    Dim rowInfo As StudentInfo
    Dim i As Long
    For i = LBound(studentData, 1) To UBound(studentData, 1)
        Set rowInfo = New StudentInfo
        rowInfo.SchoolName = studentData(i, 1)
        rowInfo.StudentID = studentData(i, 2)
        rowInfo.IDWithSchool = studentData(i, 3)
        rowInfo.Student = studentData(i, 4)
        rowInfo.IDWithName = studentData(i, 5)
        rowInfo.Level = studentData(i, 6)
        rowInfo.Grade = studentData(i, 7)
        rowInfo.Status = studentData(i, 8)
        rowInfo.Exited = studentData(i, 9)

        '--- create a key value that is a unique combination of values that defines
        '    a single (non-duplicate) entry
        Dim dictionaryKey As String
        dictionaryKey = rowInfo.StudentID &amp; rowInfo.Student
        If Not students.Exists(dictionaryKey) Then
            students.Add dictionaryKey, rowInfo
        Else
            '--- this entry exists, but which has a later exit date?
            Dim existingInfo As StudentInfo
            Set existingInfo = students(dictionaryKey)
            If rowInfo.Exited &gt; existingInfo.Exited Then
                '--- the new row's exit date is later than the existing row,
                '    so replace it
                Set students(dictionaryKey) = rowInfo
            Else
                '--- keep the existing info and ignore the current row
            End If
        End If
    Next i

    '--- now that we have the filtered student data, we'll create an array
    '    to return the data
    Dim filteredData() As Variant
    ReDim filteredData(1 To students.Count, 1 To rowInfo.NumberOfFields)

    '--- now populate!
    Dim numFields As Long
    numFields = rowInfo.NumberOfFields

    Dim key As Variant
    i = 1
    For Each key In students.Keys
        Set rowInfo = students(key)
        filteredData(i, 1) = rowInfo.SchoolName
        filteredData(i, 2) = rowInfo.StudentID
        filteredData(i, 3) = rowInfo.IDWithSchool
        filteredData(i, 4) = rowInfo.Student
        filteredData(i, 5) = rowInfo.IDWithName
        filteredData(i, 6) = rowInfo.Level
        filteredData(i, 7) = rowInfo.Grade
        filteredData(i, 8) = rowInfo.Status
        filteredData(i, 9) = rowInfo.Exited
        i = i + 1
    Next key
    FilterForRecentEnrollment = filteredData
End Function