Sort and Filter 2D Dynamic Array

Hello All,

Ok, I am trying to figure out how to sort a 2-Dimensional Dynamic Array based on 2 criteria. Then once the array is sorted, create a new array with only the rows with the most recent date. It is hard for me to describe, but I have attached an excel document with my test code. I can't even get the sorting to work properly so I haven't even started on trying to eliminate the old test dates yet.

Score Data tab -
The data in this table is exported from a website and pasted into the rows below the blue headings. The red headings have formulas in them and shouldnt be included in the array that is printed, but the Full Name column is a sorting criteria. I have the existing macro printing the correct columns, but the sorting isnt working. Dont change where the data is printed.

LATEST -Score Data tab-
This is the result I want the macro to produce. A sorted list which then eliminates all data except for the most recent entries for each person.

All Personnel - Scores tab-
The computer program where the original data is copied from does not always contain all the personnel I need. So this tab pulls the most recent data from the "LATEST -Score Data" tab and allows for the manual entry of data if that person is not included in that tab. No changes needed here.

I have one macro that works which uses the autofilter, but then I have to manually copy and paste that sorted list onto the "LATEST -Score Data" tab. I would like to eliminate that step.

Module 1 - The macro I need help with described above
Module 2 - AutoFilter macro that works how I want (except it doesnt paste the cells)
Module 3 - macro which clears the Autofilter after sorting the data

Let me know if this post doesnt make sense. I think it will make sense if you look at the attachment though. Thank you all in advance!

Unfortuantely, at work I cannot download so cant see your file however I was recently passed this function to sort a 2D array

Please Login or Register  to view this content.

The macro needs to do the following:

Original Data:
col1 col2 col3 col4
AAA 35 1-Jan-14 PASS
RRR 20 4-Nov-12 FAIL
BBB 45 5-Mar-13 PASS
AAA 32 14-Jun-14 PASS
BBB 13 2-Dec-13 FAIL

Data after running macro:
col1 col2 col3 col4
AAA 32 14-Jun-14 PASS
BBB 13 2-Dec-13 FAIL
RRR 20 4-Nov-12 FAIL

Below is what I have currently in the attachement if you cant open it. I fixed the sorting problem last night. Just some bone head mistakes I was too tired to see yesterday. Any ideas on how to delete the older rows and only keep the most recent?
-------------------
Option Explicit
Option Base 1


Sub BubbleSort_MostRecentAPFT()

Application.ScreenUpdating = False

Dim v As Variant
Dim i As Integer, z As Integer
Dim j As Integer, ci As Integer
Dim r As Integer, c As Integer
Dim temp As Variant
Dim Personnel() As Variant

Dim Rows As Integer
Dim Cols As Integer
Dim FRow As Integer
Dim LRow As Integer

Rows = WorksheetFunction.CountA(Worksheets(3).Columns(1)) - 2
Cols = 14 'WorksheetFunction.CountA(Worksheets(3).Rows(2)) - 1

ReDim Personnel(Rows, Cols)

For i = 1 To Rows
For z = 1 To Cols - 1
Personnel(i, z) = Worksheets(3).Cells(i + 2, z)
Next z
Next i

FRow = LBound(Personnel, 1)
LRow = UBound(Personnel, 1)

'Bubble sort 1st column (full name)

ci = LBound(Personnel, 2) '1st column index
For i = FRow To LRow
For j = i + 1 To LRow
If Personnel(i, ci) > Personnel(j, ci) Then
For c = LBound(Personnel, 2) To UBound(Personnel, 2)
temp = Personnel(i, c)
Personnel(i, c) = Personnel(j, c)
Personnel(j, c) = temp
Next
End If
Next
Next

'Bubble sort 10th column (test date)

ci = LBound(Personnel, 2) '1st column index
For i = FRow To LRow
For j = i + 1 To LRow
If Personnel(i, ci) = Personnel(j, ci) Then 'compare rows in 1st column
If Personnel(i, ci + 9) > Personnel(j, ci + 9) Then
For c = LBound(Personnel, 2) To UBound(Personnel, 2)
temp = Personnel(i, c)
Personnel(i, c) = Personnel(j, c)
Personnel(j, c) = temp
Next
End If
End If
Next
Next

For i = 1 To Rows
For z = 2 To Cols
ActiveSheet.Cells(i + 2, z + 14).Value = Personnel(i, z)
Next z
Next i

End Sub

pjwhitfield - thanks for that other code for sorting! Before I replaced what I had with the code you gave me I gave mine a quick once over and found my mistakes. But I will definitely hang on to this!

So this is the code I came up with for deleting the old test data from the array... Instead of deleting the data, I am just transferring the desired data into a different array. Or at least trying to.... It keeps giving me an error saying it is out of range (error 9). I dont really know why that is.... The code is below:

Option Explicit
Option Base 1


Sub BubbleSort_MostRecentAPFT()

Application.ScreenUpdating = False

Dim v As Variant
Dim i As Integer, z As Integer
Dim j As Integer, ci As Integer
Dim r As Integer, c As Integer
Dim x As Integer
Dim temp As Variant
Dim Personnel() As Variant
Dim RPersonnel() As Variant

Dim Rows As Integer
Dim Cols As Integer
Dim FRow As Integer
Dim LRow As Integer

Rows = WorksheetFunction.CountA(Worksheets(3).Columns(1)) - 2
Cols = 14 'WorksheetFunction.CountA(Worksheets(3).Rows(2)) - 1

ReDim Personnel(Rows, Cols)

For i = 1 To Rows
For z = 1 To Cols - 1
Personnel(i, z) = Worksheets(3).Cells(i + 2, z)
Next z
Next i

FRow = LBound(Personnel, 1)
LRow = UBound(Personnel, 1)

'Bubble sort 1st column (full name)

ci = LBound(Personnel, 2) '1st column index
For i = FRow To LRow
For j = i + 1 To LRow
If Personnel(i, ci) > Personnel(j, ci) Then
For c = LBound(Personnel, 2) To UBound(Personnel, 2)
temp = Personnel(i, c)
Personnel(i, c) = Personnel(j, c)
Personnel(j, c) = temp
Next
End If
Next
Next

'Bubble sort 10th column (test date)

ci = LBound(Personnel, 2) '1st column index
For i = FRow To LRow
For j = i + 1 To LRow
If Personnel(i, ci) = Personnel(j, ci) Then 'compare rows in 1st column
If Personnel(i, ci + 9) > Personnel(j, ci + 9) Then
For c = LBound(Personnel, 2) To UBound(Personnel, 2)
temp = Personnel(i, c)
Personnel(i, c) = Personnel(j, c)
Personnel(j, c) = temp
Next
End If
End If
Next
Next

x = 1
ci = LBound(Personnel, 2) '1st column index
For i = FRow To LRow
For j = i + 1 To LRow
If Personnel(i, ci) <> Personnel(j, ci) Then 'compare rows in 1st column
For c = LBound(Personnel, 2) To UBound(Personnel, 2)
ReDim Preserve RPersonnel(x, Cols)
RPersonnel(x, c) = Personnel(i, c)
Next
x = x + 1
End If
Next
Next

For i = 1 To x
For z = 2 To Cols
ActiveSheet.Cells(i + 2, z + 14).Value = RPersonnel(i, z)
Next z
Next i

End Sub

Any help would be greatly appreciated...