使用“数值比较”将唯一行保存在二维数组中

我使用下面的代码来遍历电子表格中的行，并将唯一的项目保存到二维数组中。 我知道唯一项目的数量， arrLenvariables保存这个数字。

如果find与前一行具有相同prNr（标识一组项目的唯一编号）的行，则检查是否具有较低优先级 。 如果它具有较低的优先级，则应该replace二维数组中的项目。

我的问题是， prArrCountvariables递增超过我的电子表格中唯一的prNr条目的数量。 根据我不应该这样做，但有人可以帮我找出原因吗？

'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

我喜欢使用脚本字典来pipe理重复项。 下面创build一个脚本字典，并添加一个5行1D数组作为任何新的prNr的值。 如果prNr存在，则检查先前版本的priority是否较高，如果存在，则将新数组作为该密钥的值存储在字典中。

 '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 

请参阅我的编辑。 这将在一个新行中输出每个键，数组中的每个元素都与列A中的键相关。您只需要更新工作簿，工作表和范围以满足您的需要。