Have this long convoluted program, called when a cell in the relevant column on a given sheet is changed, for the purpose of identifying cases where there are duplicates in the WO value (column D) and keeping them together while sorting by other values (as an exception to the general sorting rules I am implementing), so long as their District value (column c) is the same. The way I am trying to do this is by using a helper column where (after all of the other sorting is done) I assign each row an integer in order, then if the program sees a duplicate WO value where the district is also the same, it changes the helper column value to the same number as the first instance of that WO in that district, and then the sheet will sort by that column last.
The program seems to be working as intended up until I try to assign a value to pos and it always comes up as an error, even when the WO is a duplicate and I have verified that it is in dupArray. I have also verified that wo and search are both strings.
EDIT: Adding example table of data being sorted, relevant columns are District, WO#, and Order Helper (the helper column). In this example, while the table is being primarily sorted by district and priority, because there are 2 instances of WO# 123 in Los Angeles, the order helper value of the second instance is reassigned from 5 to 3 and then resorted so it remains grouped with the other instance.
| Due Date | Days Until Due | DISTRICT | WO# | Assigned | Facility | Description | PRIORITY | Extra | DATE RECEIVED | Order Helper |
|---|---|---|---|---|---|---|---|---|---|---|
| 2024-11-22 | OVERDUE | New York | 123 | Yes | n/a | n/a | A | 10/1/2024 | 1 | |
| 2024-12-26 | 0 | New York | 345 | No | n/a | n/a | B | 10/1/2024 | 2 | |
| 2024-11-26 | OVERDUE | Los Angeles | 123 | No | n/a | n/a | A | 10/1/2024 | 3 | |
| 2024-11-26 | OVERDUE | Los Angeles | 123 | No | n/a | n/a | B | 10/1/2024 | 3 | |
| 2024-11-22 | OVERDUE | Los Angeles | 678 | No | n/a | n/a | A | 10/1/2024 | 4 |
Public Sub masterWOSort(sheet As String, tb As String)
With Sheets(sheet)
Dim wo As String
Dim tb2 As ListObject
Set tb2 = .ListObjects(tb)
Dim count As Integer: count = 0
Dim t As Long: t = 1
Dim oc As Integer: oc = 0
Dim numSave As Integer
Dim district As String
For Each rw In tb2.DataBodyRange.Rows ' put a seRuential number next to each row
rw.Cells(11).Value = t
t = t + 1
Next rw
Dim allWo() As Variant
ReDim allWo(1 To t - 1)
Dim c As Integer: c = 1
For Each rw In tb2.DataBodyRange.Rows
allWo(c) = rw.Cells(4).Value
c = c + 1
Next rw
'make unique list of allWo()
Dim uniqueWO() As Variant
uniqueWO() = CreateUniqueList(3, t + 1)
Dim dupArray() As String
Dim j As Integer: j = 1
Dim z As Integer: z = 1
Dim i As Integer: i = 1
'create pasted ranges
For Each u In uniqueWO()
'paste to column whatever row j
.Cells(j, 30).Value = uniqueWO(j)
j = j + 1
Next u
For Each a In allWo()
'paste to column whatever row j
.Cells(z, 31).Value = allWo(z)
z = z + 1
Next a
'determine length of uniqueWo() and allWo()
Dim ulength As Integer
ulength = UBound(uniqueWO, 1) - LBound(uniqueWO, 1)
Dim alength As Integer
alength = UBound(allWo, 1) - LBound(allWo, 1)
'create ranges of uniqueWo and allWo
Dim uRng As Range
Dim uString As String
uString = "AD1:AD" & ulength
Set uRng = ActiveSheet.Range(uString)
Dim aRng As Range
Dim aString As String
aString = "AE1:AE" & alength
Set aRng = ActiveSheet.Range(aString)
'for each value in the pasted range, check how often it appears in allwo(), if multiple times then put in another array
For counter = 1 To ulength
If WorksheetFunction.CountIf(aRng, uRng.Cells(counter)) > 1 Then
ReDim Preserve dupArray(1, 1 To i)
dupArray(0, i) = uniqueWO(counter)
dupArray(1, i) = 0
i = i + 1
End If
Next counter
Dim pos As Variant
Dim search As String
For Each rw In tb2.DataBodyRange.Rows ' replace number with the one of the first instance of WO if it is a multiple
wo = rw.Cells(4).Value
If IsInArray(wo, dupArray) = True Then
For z = 1 To UBound(dupArray, 2)
On Error Resume Next
search = Application.Index(dupArray, 1, z)
pos = Application.Match(wo, search, 0)
On Error Resume Next
dupArray(1, pos) = dupArray(1, pos) + 1
If IsError(pos) = False Then Exit For
Next
If dupArray(1, pos) = 1 Then
numSave = rw.Cells(11).Value
district = rw.Cells(3).Value
ElseIf rw.Cells(3).Value = district Then
rw.Cells(11).Value = numSave
End If
End If
Next rw
'delete helper columns for allWo and uniqueWo
.Columns(30).ClearContents
.Columns(31).ClearContents
End With
End Sub
Function CreateUniqueList(nStart As Long, nEnd As Long) As Variant
Dim Col As New Collection
Dim arrTemp() As Variant
Dim valCell As String
Dim i As Integer
'Populate Temporary Collection
On Error Resume Next
For i = 0 To nEnd
valCell = Range("D" & nStart).Offset(i, 0).Value
Col.add valCell, valCell
Next i
Err.Clear
On Error GoTo 0
'Resize n
nEnd = Col.count
'Redeclare array
ReDim arrTemp(1 To nEnd)
'Populate temporary array by looping through the collection
For i = 1 To Col.count
arrTemp(i) = Col(i)
Next i
'return the temporary array to the function result
CreateUniqueList = arrTemp()
End Function
Public Function IsInArray(stringToBeFound As Variant, arr As Variant) As Boolean
Dim i
For i = LBound(arr, 2) To UBound(arr, 2)
If arr(0, i) = stringToBeFound Then
IsInArray = True
Exit Function
End If
Next i
IsInArray = False
End Function
Public Sub masterWOSort(shtName As String, tblName As String)
Dim tb As ListObject, rw As Range
Dim dict As Object, k, n As Long
Set dict = CreateObject("Scripting.Dictionary")
Set tb = Sheets(shtName).ListObjects(tblName)
' Fill helper columm
For Each rw In tb.DataBodyRange.Rows
'unique key DISTRICT WO#
k = rw.Columns(3) & vbTab & rw.Columns(4)
If dict.exists(k) Then
rw.Columns(11) = dict(k)
Else
n = n + 1
rw.Columns(11) = n ' Order Helper
dict.Add k, n
End If
Next
End Sub