Option Explicit
Sub test()
Dim arr, dic(1), i, j, k, a, b
For i = 0 To UBound(dic)
Set dic(i) = CreateObject("scripting.dictionary")
Next
arr = Range("k6:l" & Cells(Rows.Count, "l").End(xlUp).Row)
For i = 1 To UBound(arr, 1): dic(0)(arr(i, 1)) = arr(i, 2): Next
arr = Range("g4:i" & Cells(Rows.Count, "i").End(xlUp).Row)
For i = 1 To UBound(arr, 1)
If Len(arr(i, 1)) Then
dic(1)(arr(i, 1)) = dic(1)(arr(i, 1)) + 1
arr(i, 1) = dic(0)(arr(i, 1)) & "-" & Format(dic(1)(arr(i, 1)), "000")
End If
Next
[i4].Resize(UBound(arr, 1)) = arr
arr = Range("n4:w" & Cells(Rows.Count, "n").End(xlUp).Row + 1)
For i = 1 To UBound(arr, 1) - 1: arr(i, 10) = i: Next
Call bsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 1)
For i = 1 To UBound(arr, 1) - 1
For j = i To UBound(arr, 1) - 1
If arr(j, 1) <> arr(j + 1, 1) Then
Call bsort(arr, i, j, 1, UBound(arr, 2), 6)
For a = i To j
For b = a To j
If arr(b, 6) <> arr(b + 1, 6) Or arr(b, 1) <> arr(b + 1, 1) Then
For k = a To b: arr(k, 8) = b - a + 1: Next
a = b: Exit For
End If
Next b, a
i = j: Exit For
End If
Next j, i
Call bsort(arr, 1, UBound(arr, 1) - 1, 1, UBound(arr, 2), 10)
[n4].Resize(UBound(arr, 1) - 1, UBound(arr, 2) - 1) = arr
End Sub
Function bsort(arr, first, last, left, right, key)
Dim i, j, k, t
For i = first To last - 1
For j = first To last + first - 1 - i
If arr(j, key) > arr(j + 1, key) Then
For k = left To right
t = arr(j, k): arr(j, k) = arr(j + 1, k): arr(j + 1, k) = t
Next
End If
Next j, i
End Function |