Saving Unique Rows in a 2D array with a Value Comparison - arrays

Question

I use the following code to cycle through rows in a spreadsheet, and save unique items into a 2D array. I know the number of unique items, and the arrLen variable holds that number.
If a row with the same prNr (unique number identifying a set of items) as a previous row is found, a check is done to see which has the lower priority. If it has a lower priority, it should replace the item in the 2D array.
My problem is that the prArrCount variable increments past the number of unique prNr entries in my spreadsheet. According to me it should not do this, but can someone help me find out why?
'Cycle through PRs, store values in 2D array
'Create 2D array
Dim prData() As String
ReDim prData(arrLen, 6)
'Find the last row in the spreadsheet to iterate through all entries
Dim lastRow As Integer
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Create data variables
Dim i, prArrCount As Integer
Dim prNr As String
Dim description As String
Dim Value As Double
Dim srmRFQ As String
Dim requisitionDate As Date
Dim deliveryDate As Date
Dim delivery As Integer
Dim delta As Integer
Dim priority As Integer
Dim newPR As Integer
Dim initFlag As Integer
'Set initial values
initFlag = 1
prArrCount = 0
newPR = 1
'Start for loop to iterate through all entries in the spreadsheet
For i = 2 To lastRow
'Read in the PR line values
prNr = Range("B" & i).Value
description = Range("G" & i).Value
srmRFQ = Range("E" & i).Value
requisitionDate = DateValue(Range("O" & i).Value)
Value = Range("R" & i).Value
If Not Left(Range("P" & i).Value, 1) = "0" Then
deliveryDate = DateValue(Range("P" & i).Value)
Else
deliveryDate = 0
End If
If Range("S" & i).Value = "" Then
delivery = 0
Else
delivery = Range("S" & i).Value
End If
If Range("Z" & i).Value = "Invalid" Then
priority = 9999
delta = 0
Else
priority = Range("Z" & i).Value
delta = Range("Y" & i).Value
End If
'Check if it is the first iteration of the loop
If initFlag = 1 Then
initFlag = 0
ElseIf Not prNr = prData(prArrCount, 0) Then
prArrCount = prArrCount + 1
newPR = 1
End If
'Check if values should be written into 2D PR array
If newPR = 1 Then
prData(prArrCount, 0) = prNr '(0) PR Number
prData(prArrCount, 1) = description '(1) Description
prData(prArrCount, 2) = priority '(2) Days left to order
prData(prArrCount, 3) = deliveryDate '(3) Delivery date
prData(prArrCount, 4) = delivery '(4) Lead time
newPR = 0
ElseIf priority < prData(prArrCount, 2) Then
prData(prArrCount, 0) = prNr '(0) PR Number
prData(prArrCount, 1) = description '(1) Description
prData(prArrCount, 2) = priority '(2) Days left to order
prData(prArrCount, 3) = deliveryDate '(3) Delivery date
prData(prArrCount, 4) = delivery '(4) Lead time
End If
Next i

Answer 1

I like to use scripting dictionaries to manage duplicates. The below creates a scripting dictionary and adds a 5 row 1D array as the value for any new prNr. If the prNr exists, it checks if the priority of the prior version is greater, and if so, stores the new array as the value of that key in the dictionary.
'Cycle through PRs, store values in 2D array
'Create 2D array
Dim prData() As String
ReDim prData(arrLen, 6)
'Find the last row in the spreadsheet to iterate through all entries
Dim lastRow As Integer
lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Create data variables
Dim i as Integer, prArrCount As Integer
Dim prNr As String
Dim description As String
Dim Value As Double
Dim srmRFQ As String
Dim requisitionDate As Date
Dim deliveryDate As Date
Dim delivery As Integer
Dim delta As Integer
Dim priority As Integer
Dim newPR As Integer
Dim initFlag As Integer
Dim dict As New Scripting.Dictionary 'Note you need the Microsoft Scripting Runtime Library
Dim x(4) as Variant
Dim Key as Variant
Dim Anchor as Range
'Set initial values
initFlag = 1
prArrCount = 0
newPR = 1
'Start for loop to iterate through all entries in the spreadsheet
For i = 2 To lastRow
'Read in the PR line values
prNr = Range("B" & i).Value
description = Range("G" & i).Value
srmRFQ = Range("E" & i).Value
requisitionDate = DateValue(Range("O" & i).Value)
Value = Range("R" & i).Value
If Not Left(Range("P" & i).Value, 1) = "0" Then
deliveryDate = DateValue(Range("P" & i).Value)
Else
deliveryDate = 0
End If
If Range("S" & i).Value = "" Then
delivery = 0
Else
delivery = Range("S" & i).Value
End If
If Range("Z" & i).Value = "Invalid" Then
priority = 9999
delta = 0
Else
priority = Range("Z" & i).Value
delta = Range("Y" & i).Value
End If
x(0) = prNr
x(1) = description
x(2) = priority
x(3) = deliveryDate
x(4) = delivery
If Not dict.Exists(prNr) Then
dict.Add prNr, x
Else
If priority < dict(prNr)(2) Then
dict(prNr) = x
End If
End If
Next i
With Workbooks("Workbook Name").Sheets("Sheet Name") 'Change references to match what you need
For Each Key in dict.Keys
Set Anchor = .Range("A" & .Rows.Count).End(xlUp).Offset(1,0)
For i = Lbound(dict(key),1) to Ubound(dict(key),1)
Anchor.Offset(0,i) = dict(key)(i)
Next i
Next key
End With
Please see my edit. This will output each key in a new line, and each element in the array related to the key starting in column A. You just need to update the workbook, worksheet and range to match your needs.