On Mar 19, 5:40*pm, "Peter T" <peter_t@discussions wrote:
Another one -

Sub Dups7()
Dim i As Long, j As Long, nSame As Long
Dim arr1, arr2
Dim rng As Range

* * Set rng = ActiveSheet.Range("A1") ' < change to suit
* * Set rng = Range(rng, rng.End(xlDown))

* * arr1 = rng.Value
* * For i = 1 To UBound(arr1)
* * * * arr1(i, 1) = Left$(arr1(i, 1), 7)
* * Next

* * BubbleSort2D arr1

* * ReDim arr2(1 To UBound(arr1), 1 To 2)

* * nSame = 0

* * For i = 2 To UBound(arr1)
* * * * nSame = nSame + 1
* * * * If arr1(i - 1, 1) < arr1(i, 1) Then
* * * * * * j = j + 1
* * * * * * arr2(j, 1) = arr1(i - 1, 1)
* * * * * * arr2(j, 2) = nSame
* * * * * * nSame = 0
* * * * End If
* * Next

* * j = j + 1
* * arr2(j, 1) = Left$(arr1(i - 1, 1), 7)
* * arr2(j, 2) = nSame + 1

* * ' in 1st & 2nd col to right by no. of uniques, adapt as required
* * Set rng = rng(1, 1).Offset(0, 1).Resize(j, 2)

* * rng.Columns(1).NumberFormat = "@" * *' for those leading zeros

* * rng.Value = arr2

End Sub

Function BubbleSort2D(vArr)
Dim tmp As Variant
Dim i As Long
Dim bDone As Boolean

* * ' sort first dimension of a 2D array
* * Do
* * * * bDone = True
* * * * For i = LBound(vArr) To UBound(vArr) - 1
* * * * * * If vArr(i, 1) vArr(i + 1, 1) Then
* * * * * * * * bDone = False
* * * * * * * * tmp = vArr(i, 1)
* * * * * * * * vArr(i, 1) = vArr(i + 1, 1)
* * * * * * * * vArr(i + 1, 1) = tmp
* * * * * * End If
* * * * Next i
* * Loop While Not bDone

End Function

Regards,
Peter T

"Sinner" wrote in message

...



Hi,

I have the following list.

08459087671
08459087673
08465228672
08429087671
08429087571
08454287667
08454287657
-----------------------------------
Would like to calculate the following i.e. the formula or VB code
should first list items based on first 7 characters uniqueness & then
the quanity count.

Result:
-----------------------------------
Items * * * * Qty
0845908 * * * 2
0846522 * * * 1
0842908 * * * 2
0845428 * * * 2- Hide quoted text -

- Show quoted text -

Thanks Peter but its only giving 65536 in C1 of sheet 2.
Can you check pls.