CODEWITHSUNDEEP
arraysvbaexcel
Cornel Verster
Cornel Verster

Reputation: 1781

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

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

Upvotes: 0

Views: 69

Answers (1)

Kyle
Kyle

Reputation: 2545

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.

Upvotes: 1

Related Questions