| Home |
| Search |
| Today's Posts |
|
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
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 |
|
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 |
|
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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. |
|
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 |
|
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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. |
|
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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. |
|
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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, I hope you can adjust your code. Thx. |
|
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 |
|
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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. |
|
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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. |
|
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 -------------------------------------------------------------------------------------------------------- |
|
#12
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 |
|
#13
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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 |
|
#14
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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. |
|
#15
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
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?? |
|
#16
Posted to microsoft.public.excel.programming
|
|||
|
|||
|
Message for Joel
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 - Joel can you pls check. |
| Reply |
| Thread Tools | Search this Thread |
| Display Modes | |
|
|
Similar Threads
|
||||
| Thread | Forum | |||
| Count Unique Records | Excel Worksheet Functions | |||
| count unique records | Excel Worksheet Functions | |||
| Count Unique Records | New Users to Excel | |||
| pivot count unique records only | Excel Discussion (Misc queries) | |||
| Count Unique Records | Excel Worksheet Functions | |||
Linear Mode
