List & count unique records

S

Sinner

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
 
J

Joel

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
 
S

Sinner

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








- Show quoted text -
Click to expand...

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

Peter T

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
 
J

Joel

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
 
S

Sinner

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









- Show quoted text -
Click to expand...

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

Sinner

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








- Show quoted text -
Click to expand...

Joel, I hope you can adjust your code.
Thx.
 
P

Peter T

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









- Show quoted text -
Click to expand...

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
Click to expand...

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
 
S

Sinner

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-


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 -
Click to expand...

Thankyou Peter.
 
S

Sinner

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







- Show quoted text -
Click to expand...

Thanks Joel.
 
S

Sinner

Thanks Joel.- Hide quoted text -

- Show quoted text -
Click to expand...

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

Peter T

"Sinner" <[email protected]> wrote in message
Click to expand...
Thankyou Peter.- Hide quoted text -

- Show quoted text -
Click to expand...

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
Click to expand...
 
S

Sinner

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 -
Click to expand...

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
Click to expand...
 
S

Sinner

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 -
Click to expand...

Joel??
 
S

Sinner

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







- Show quoted text -
Click to expand...

Joel can you pls check.
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Datewise table view with unique count 1
Help with the script 1
Count unique values - Match and conditional IF 2
How to list and count unique records 4
Count Unique Items 9
Multiple Lists from Unique Data 1
Count unique records that also meet criteria 3
Case sensitive unique list 2

Top