ExcelBanter - List & count unique records

ExcelBanter (https://www.excelbanter.com/)

- Excel Programming (https://www.excelbanter.com/excel-programming/)

- - List & count unique records (https://www.excelbanter.com/excel-programming/407947-list-count-unique-records.html)

Sinner

List & count unique records

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

joel

List & count unique records

Sub get_unique()

Sh1RowCount = 1
Sh2RowCount = 1
With Sheets("Sheet1")
Do While .Range("A" & Sh1RowCount) < ""
FNum = Left(.Range("A" & Sh1RowCount), 7)
With Sheets("Sheet2")
Set c = .Columns("A:A").Find(what:=FNum, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Range("A" & Sh2RowCount) = FNum
.Range("B" & Sh2RowCount) = 1
Sh2RowCount = Sh2RowCount + 1
Else
.Range("B" & c.Row) = .Range("B" & c.Row) + 1
End If
End With

Sh1RowCount = Sh1RowCount + 1
Loop
End With

End Sub

"Sinner" wrote:

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

Sinner

List & count unique records

On Mar 19, 3:41*pm, Joel wrote:
Sub get_unique()

Sh1RowCount = 1
Sh2RowCount = 1
With Sheets("Sheet1")
* *Do While .Range("A" & Sh1RowCount) < ""
* * * FNum = Left(.Range("A" & Sh1RowCount), 7)
* * * With Sheets("Sheet2")
* * * * *Set c = .Columns("A:A").Find(what:=FNum, _
* * * * * * LookIn:=xlValues, lookat:=xlWhole)
* * * * *If c Is Nothing Then
* * * * * * .Range("A" & Sh2RowCount) = FNum
* * * * * * .Range("B" & Sh2RowCount) = 1
* * * * * * Sh2RowCount = Sh2RowCount + 1
* * * * *Else
* * * * * * .Range("B" & c.Row) = .Range("B" & c.Row) + 1
* * * * *End If
* * * End With

* * * Sh1RowCount = Sh1RowCount + 1
* *Loop
End With

End Sub

"Sinner" wrote:
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 -

Joel it's working only if I set cell formatting of columnA of sheet1 &
sheet2 as text.
Can you incorporate same in the code?
Secondly I would like the item list to be in ascending order.

Thx.

Peter T

List & count unique records

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

joel

List & count unique records

The leading zero in the numbers was causing the problem.

Sub get_unique()

Dim FNum As String

Sh1RowCount = 1
Sh2RowCount = 1
With Sheets("Sheet1")
Do While .Range("A" & Sh1RowCount).Text < ""
FNum = Left(.Range("A" & Sh1RowCount), 7)
With Sheets("Sheet2")
Set c = .Columns("A:A").Find(what:=FNum, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Range("A" & Sh2RowCount).NumberFormat = "@"
.Range("A" & Sh2RowCount) = FNum
.Range("B" & Sh2RowCount) = 1
Sh2RowCount = Sh2RowCount + 1
Else

.Range("B" & c.Row) = .Range("B" & c.Row) + 1
End If
End With

Sh1RowCount = Sh1RowCount + 1
Loop
End With

End Sub

"Sinner" wrote:

On Mar 19, 3:41 pm, Joel wrote:
Sub get_unique()

Sh1RowCount = 1
Sh2RowCount = 1
With Sheets("Sheet1")
Do While .Range("A" & Sh1RowCount) < ""
FNum = Left(.Range("A" & Sh1RowCount), 7)
With Sheets("Sheet2")
Set c = .Columns("A:A").Find(what:=FNum, _
LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
.Range("A" & Sh2RowCount) = FNum
.Range("B" & Sh2RowCount) = 1
Sh2RowCount = Sh2RowCount + 1
Else
.Range("B" & c.Row) = .Range("B" & c.Row) + 1
End If
End With

Sh1RowCount = Sh1RowCount + 1
Loop
End With

End Sub

"Sinner" wrote:
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 -

Joel it's working only if I set cell formatting of columnA of sheet1 &
sheet2 as text.
Can you incorporate same in the code?
Secondly I would like the item list to be in ascending order.

Thx.

Sinner

List & count unique records

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.

Sinner

List & count unique records

Peter T

List & count unique records

"Sinner" wrote in message
...
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.

-----------------------------------------

I think it's you that needs to check what you are doing!

Look at this line in the demo-
Set rng = ActiveSheet.Range("A1") ' < change to suit

Change A1 to the address of the first cell of your data

Alternatively, insert the following new line

Set rng = Selection ' insert this line just above arr1 = rng.Value
arr1 = rng.Value ' old line

Manually select the cells that contain your long text numbers and run
"Dups7"

Regards,
Peter T

Sinner

List & count unique records

On Mar 19, 6:34*pm, "Peter T" <peter_t@discussions wrote:
"Sinner" wrote in message

...
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.

-----------------------------------------

I think it's you that needs to check what you are doing!

Look at this line in the demo-

Set rng = ActiveSheet.Range("A1") ' < change to suit

Change A1 to the address of the first cell of your data

Alternatively, insert the following new line

Set rng = Selection ' insert this line just above arr1 = rng.Value
arr1 = rng.Value ' old line

Manually select the cells that contain your long text numbers and run
"Dups7"

Regards,
Peter T- Hide quoted text -

- Show quoted text -

Thankyou Peter.

Sinner

List & count unique records

On Mar 19, 6:01*pm, Joel wrote:
The leading zero in the numbers was causing the problem.

Sub get_unique()

Dim FNum As String

Sh1RowCount = 1
Sh2RowCount = 1
With Sheets("Sheet1")
* *Do While .Range("A" & Sh1RowCount).Text < ""
* * * FNum = Left(.Range("A" & Sh1RowCount), 7)
* * * With Sheets("Sheet2")
* * * * *Set c = .Columns("A:A").Find(what:=FNum, _
* * * * * * LookIn:=xlValues, lookat:=xlWhole)
* * * * *If c Is Nothing Then
* * * * * * .Range("A" & Sh2RowCount).NumberFormat = "@"
* * * * * * .Range("A" & Sh2RowCount) = FNum
* * * * * * .Range("B" & Sh2RowCount) = 1
* * * * * * Sh2RowCount = Sh2RowCount + 1
* * * * *Else

* * * * * * .Range("B" & c.Row) = .Range("B" & c.Row) + 1
* * * * *End If
* * * End With

* * * Sh1RowCount = Sh1RowCount + 1
* *Loop
End With

End Sub

"Sinner" wrote:
On Mar 19, 3:41 pm, Joel wrote:
Sub get_unique()

Sh1RowCount = 1
Sh2RowCount = 1
With Sheets("Sheet1")
* *Do While .Range("A" & Sh1RowCount) < ""
* * * FNum = Left(.Range("A" & Sh1RowCount), 7)
* * * With Sheets("Sheet2")
* * * * *Set c = .Columns("A:A").Find(what:=FNum, _
* * * * * * LookIn:=xlValues, lookat:=xlWhole)
* * * * *If c Is Nothing Then
* * * * * * .Range("A" & Sh2RowCount) = FNum
* * * * * * .Range("B" & Sh2RowCount) = 1
* * * * * * Sh2RowCount = Sh2RowCount + 1
* * * * *Else
* * * * * * .Range("B" & c.Row) = .Range("B" & c.Row) + 1
* * * * *End If
* * * End With

* * * Sh1RowCount = Sh1RowCount + 1
* *Loop
End With

End Sub

"Sinner" wrote:
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 -

Joel it's working only if I set cell formatting of columnA of sheet1 &
sheet2 as text.
Can you incorporate same in the code?
Secondly I would like the item list to be in ascending order.

Thx.- Hide quoted text -

- Show quoted text -

Thanks Joel.

Sinner

List & count unique records datewise (table form)

On Mar 19, 8:11*pm, Sinner wrote:
On Mar 19, 6:01*pm, Joel wrote:

The leading zero in the numbers was causing the problem.

Sub get_unique()

Dim FNum As String

Sh1RowCount = 1
Sh2RowCount = 1
With Sheets("Sheet1")
* *Do While .Range("A" & Sh1RowCount).Text < ""
* * * FNum = Left(.Range("A" & Sh1RowCount), 7)
* * * With Sheets("Sheet2")
* * * * *Set c = .Columns("A:A").Find(what:=FNum, _
* * * * * * LookIn:=xlValues, lookat:=xlWhole)
* * * * *If c Is Nothing Then
* * * * * * .Range("A" & Sh2RowCount).NumberFormat = "@"
* * * * * * .Range("A" & Sh2RowCount) = FNum
* * * * * * .Range("B" & Sh2RowCount) = 1
* * * * * * Sh2RowCount = Sh2RowCount + 1
* * * * *Else

* * * * * * .Range("B" & c.Row) = .Range("B" & c.Row) + 1
* * * * *End If
* * * End With

* * * Sh1RowCount = Sh1RowCount + 1
* *Loop
End With

End Sub

"Sinner" wrote:
On Mar 19, 3:41 pm, Joel wrote:
Sub get_unique()

Sh1RowCount = 1
Sh2RowCount = 1
With Sheets("Sheet1")
* *Do While .Range("A" & Sh1RowCount) < ""
* * * FNum = Left(.Range("A" & Sh1RowCount), 7)
* * * With Sheets("Sheet2")
* * * * *Set c = .Columns("A:A").Find(what:=FNum, _
* * * * * * LookIn:=xlValues, lookat:=xlWhole)
* * * * *If c Is Nothing Then
* * * * * * .Range("A" & Sh2RowCount) = FNum
* * * * * * .Range("B" & Sh2RowCount) = 1
* * * * * * Sh2RowCount = Sh2RowCount + 1
* * * * *Else
* * * * * * .Range("B" & c.Row) = .Range("B" & c.Row) + 1
* * * * *End If
* * * End With

* * * Sh1RowCount = Sh1RowCount + 1
* *Loop
End With

End Sub

"Sinner" wrote:
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 -

Joel it's working only if I set cell formatting of columnA of sheet1 &
sheet2 as text.
Can you incorporate same in the code?
Secondly I would like the item list to be in ascending order.

Thx.- Hide quoted text -

- Show quoted text -

Thanks Joel.- Hide quoted text -

- Show quoted text -

Joel,

If there are dates involved, columnA of sheet1 is date, columnB of
sheet1 is the list of numbers, how can we modify to get the following
result in sheet2:
--------------------------------------------------------------------------------------------------------
DATE: 0845908 0846522 0842908
0845428
02-03-2008 2
04-03-2008 1 2
07-03-2008
2
--------------------------------------------------------------------------------------------------------

Sinner

List & count unique records

On Mar 19, 8:11*pm, Sinner wrote:
On Mar 19, 6:34*pm, "Peter T" <peter_t@discussions wrote:

"Sinner" wrote in message

...
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.

-----------------------------------------

I think it's you that needs to check what you are doing!

Look at this line in the demo-

Set rng = ActiveSheet.Range("A1") ' < change to suit

Change A1 to the address of the first cell of your data

Alternatively, insert the following new line

Set rng = Selection ' insert this line just above arr1 = rng.Value
arr1 = rng.Value ' old line

Manually select the cells that contain your long text numbers and run
"Dups7"

Regards,
Peter T- Hide quoted text -

- Show quoted text -

Thankyou Peter.- Hide quoted text -

- Show quoted text -

Joel,

Can you further change it incase datewise table is required.

Thanks

Peter T

List & count unique records

"Sinner" wrote in message
...
On Mar 19, 8:11 pm, Sinner wrote:
On Mar 19, 6:34 pm, "Peter T" <peter_t@discussions wrote:

"Sinner" wrote in message

...
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.

-----------------------------------------

I think it's you that needs to check what you are doing!

Look at this line in the demo-

Set rng = ActiveSheet.Range("A1") ' < change to suit

Change A1 to the address of the first cell of your data

Alternatively, insert the following new line

Set rng = Selection ' insert this line just above arr1 = rng.Value
arr1 = rng.Value ' old line

Manually select the cells that contain your long text numbers and run
"Dups7"

Regards,
Peter T- Hide quoted text -

- Show quoted text -

Thankyou Peter.- Hide quoted text -

- Show quoted text -

Joel,

Can you further change it incase datewise table is required.

Thanks

----------------------------------------------------------------------

You have replied to me but you have addressed the question to Joel. Who are
you asking, Joel, myself, or both.

Personally I do not understand the question, maybe you could explain what
you mean. Also clarify if the routine I posted did what you originally
asked for.

Regards,
Peter T

Sinner

List & count unique records

On Mar 20, 6:36*pm, "Peter T" <peter_t@discussions wrote:
"Sinner" wrote in message

...
On Mar 19, 8:11 pm, Sinner wrote:

On Mar 19, 6:34 pm, "Peter T" <peter_t@discussions wrote:

"Sinner" wrote in message

....
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.

-----------------------------------------

I think it's you that needs to check what you are doing!

Look at this line in the demo-

Set rng = ActiveSheet.Range("A1") ' < change to suit

Change A1 to the address of the first cell of your data

Alternatively, insert the following new line

Set rng = Selection ' insert this line just above arr1 = rng.Value
arr1 = rng.Value ' old line

Manually select the cells that contain your long text numbers and run
"Dups7"

Regards,
Peter T- Hide quoted text -

- Show quoted text -

Thankyou Peter.- Hide quoted text -

- Show quoted text -

Joel,

Can you further change it incase datewise table is required.

Thanks

----------------------------------------------------------------------

You have replied to me but you have addressed the question to Joel. Who are
you asking, Joel, myself, or both.

Personally I do not understand the question, maybe you could explain what
you mean. *Also clarify if the routine I posted did what you originally
asked for.

Regards,
Peter T- Hide quoted text -

- Show quoted text -

Dear Peter,

I did not check your code. I'll let you know about it.
Reply was to Joel.

If columnA of sheet1 are Dates & columnB is the list of numbers then
following is required:
It is same but now datewise and in table form with breakup.
------------------------------------------------------------------------------------------
Date: 0845908 0846522 0842908 0845428
02-mar-2008 2 2
04-mar-2008 1
07-
mar-2008
2
------------------------------------------------------------------------------------------

Thx.

Sinner

List & count unique records

On Mar 20, 6:58*pm, Sinner wrote:
On Mar 20, 6:36*pm, "Peter T" <peter_t@discussions wrote:

"Sinner" wrote in message

...
On Mar 19, 8:11 pm, Sinner wrote:

On Mar 19, 6:34 pm, "Peter T" <peter_t@discussions wrote:

"Sinner" wrote in message

...
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.

-----------------------------------------

I think it's you that needs to check what you are doing!

Look at this line in the demo-

Set rng = ActiveSheet.Range("A1") ' < change to suit

Change A1 to the address of the first cell of your data

Alternatively, insert the following new line

Set rng = Selection ' insert this line just above arr1 = rng.Value
arr1 = rng.Value ' old line

Manually select the cells that contain your long text numbers and run
"Dups7"

Regards,
Peter T- Hide quoted text -

- Show quoted text -

Thankyou Peter.- Hide quoted text -

- Show quoted text -

Joel,

Can you further change it incase datewise table is required.

Thanks

----------------------------------------------------------------------

You have replied to me but you have addressed the question to Joel. Who are
you asking, Joel, myself, or both.

Personally I do not understand the question, maybe you could explain what
you mean. *Also clarify if the routine I posted did what you originally
asked for.

Regards,
Peter T- Hide quoted text -

- Show quoted text -

Dear Peter,

I did not check your code. I'll let you know about it.
Reply was to Joel.

If columnA of sheet1 are Dates & columnB is the list of numbers then
following is required:
It is same but now datewise and in table form with breakup.
---------------------------------------------------------------------------*---------------
Date: * * * * * * * 0845908 * * *0846522 * * *0842908 * * *0845428
02-mar-2008 * * * * 2 * * * * * * * * * * * * * * * * * *2
04-mar-2008 * * * * * * * * * * * * * *1
07-
mar-2008
2
---------------------------------------------------------------------------*---------------

Thx.- Hide quoted text -

- Show quoted text -

Joel??

Sinner

Message for Joel

All times are GMT +1. The time now is 10:33 AM.