Reduce duplicates to 1 with a count of how many before

  • Thread starter Thread starter L. Howard
  • Start date Start date
Hi Howard,

Am Sat, 22 Feb 2014 18:05:25 -0800 (PST) schrieb L. Howard:
I have growing frustration over what appears to be a moving target of what the final out come is supposed to be, and of course I'm in over my head on the code.

Raw data in column A and as before move the non-P item up and over 1 row and 1 column.
Click to expand...

can you send me a workbook with the data and the expected result that I
can see it?


Regards
Claus B.
 
Hi Howard,

Am Sat, 22 Feb 2014 18:05:25 -0800 (PST) schrieb L. Howard:
I have growing frustration over what appears to be a moving target of what the final out come is supposed to be, and of course I'm in over my head on the code.
Raw data in column A and as before move the non-P item up and over 1 row and 1 column.
So now data is in column A and column B (which is not shown below.)
Click to expand...

I got it!
Change the For Each rngC Loop to:
..Range("C2:C" & LRow2).Formula = "=SumProduct(--(Sheet1!" _
& "$A$1:$A$" & LRow1 & "=A2),--(Sheet1!$B$1:$B$" & LRow1 & "= _
B2))"

Sub Test_CB2()
Dim LRow1 As Long, LRow2 As Long
Dim myArr As Variant

With Sheets("Sheet1")
LRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
myArr = .Range("A1:B" & LRow1)
End With

With Sheets("Sheet2")
.Range("A2").Resize(LRow1, 2) = myArr
.Range("A2:B" & LRow1 + 1).RemoveDuplicates _
Columns:=Array(1, 2), Header:=xlNo
LRow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("C2:C" & LRow2).Formula = "=SumProduct(--(Sheet1!" _
& "$A$1:$A$" & LRow1 & "=A2),--(Sheet1!$B$1:$B$" & LRow1 & "=
B2))"
End With
End Sub


Regards
Claus B.
 
Hi Howard,



Am Sat, 22 Feb 2014 18:05:25 -0800 (PST) schrieb L. Howard:








I got it!

Change the For Each rngC Loop to:

.Range("C2:C" & LRow2).Formula = "=SumProduct(--(Sheet1!" _

& "$A$1:$A$" & LRow1 & "=A2),--(Sheet1!$B$1:$B$" & LRow1 & "= _

B2))"



Sub Test_CB2()

Dim LRow1 As Long, LRow2 As Long

Dim myArr As Variant



With Sheets("Sheet1")

LRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row

myArr = .Range("A1:B" & LRow1)

End With



With Sheets("Sheet2")

.Range("A2").Resize(LRow1, 2) = myArr

.Range("A2:B" & LRow1 + 1).RemoveDuplicates _

Columns:=Array(1, 2), Header:=xlNo

LRow2 = .Cells(.Rows.Count, 1).End(xlUp).Row

.Range("C2:C" & LRow2).Formula = "=SumProduct(--(Sheet1!" _

& "$A$1:$A$" & LRow1 & "=A2),--(Sheet1!$B$1:$B$" & LRow1 & "=

B2))"

End With

End Sub





Regards

Claus B.

--
Click to expand...


Yes that really seems to be the ticket.

All my testing says BINGO!

Really appreciate you efforts.

And of course all the code is noted with '/By Claus as I pass it on.

Thanks again.

Regards,
Howard
 
Hi Howard,

Am Sun, 23 Feb 2014 01:19:18 -0800 (PST) schrieb L. Howard:
All my testing says BINGO!
Click to expand...

if you have same values in A with and without values in B macro Test_CB
doesn't give you the expected result because the value from A is only
once in the array.
With Test_CB2 you get the expected result but you use another sheet.
You can also copy the data from A:B to C:D and run RemoveDuplicates.
Then the code must be changed slightly.

If you want the output in the same sheet like Sheet1 in SkyDrive
workbook have another look in SkyDrive an go to Sheet4 and run Test_CB4


Regards
Claus B.
 
Hi Garry,

Am Sat, 22 Feb 2014 22:24:39 -0500 schrieb GS:
Thanks.., I see that now though I don't see the why of it!
Click to expand...

in the macro Test_CB2 I had no Option Base 1. But in the other macros I
had.
If I have 1D-Arrays (like the Scripting.Dictionary) into the code and
want to create 2D-Arrays out of them for me it seems easier to handle
with Option Base 1.
Now I have changed all codes (SkyDrive) to Option Base 0. ;-)


Regards
Claus B.
 
Hi Garry,
Am Sat, 22 Feb 2014 22:24:39 -0500 schrieb GS:


in the macro Test_CB2 I had no Option Base 1. But in the other macros
I had.
If I have 1D-Arrays (like the Scripting.Dictionary) into the code and
want to create 2D-Arrays out of them for me it seems easier to handle
with Option Base 1.
Now I have changed all codes (SkyDrive) to Option Base 0. ;-)


Regards
Claus B.
Click to expand...

Hi Claus,
That makes sense to me but I found it to be problematic when the module
also required zero-based arrays that dealt with control indexes OR
recordsets from delimited text files where field names were the 1st
line in the file. If missing fieldnames I'd have to prepend a line to
the file contents before splitting into an array so the 1st record is
always 1 and the record count is always UBound.

What I find when working with 1D/2D arrays is that using a separate
counter works best for building the output array while the loop counter
starts at LBound. This allows easy transition going either way, IMO.<g>

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Hi Garry,

Am Sun, 23 Feb 2014 11:50:21 -0500 schrieb GS:
What I find when working with 1D/2D arrays is that using a separate
counter works best for building the output array while the loop counter
starts at LBound. This allows easy transition going either way, IMO.<g>
Click to expand...

I am reading and writing here not only to help others. I do it also for
further learning. And your suggestions are always helpful and
instructive. Thank you.


Regards
Claus B.
 
Hi Garry,
Am Sun, 23 Feb 2014 11:50:21 -0500 schrieb GS:


I am reading and writing here not only to help others. I do it also
for further learning. And your suggestions are always helpful and
instructive. Thank you.


Regards
Claus B.
Click to expand...

Claus, please know this is mutual and you have been a great help to me
as well...

--
Garry

Free usenet access at http://www.eternal-september.org
Classic VB Users Regroup!
comp.lang.basic.visual.misc
microsoft.public.vb.general.discussion
 
Hi Claus,

Found a glitch that returns a subscript out of range.

This data errors:

P-3122
F3UT2BA000457 <note serial number here>
P-3122
F3UT3C5000495
P-3122
F3UT3C4000059
P-3123
QBDA1C7000402

This data works fine:

P-3122
P-65439 <No serial number, P number instead>
P-3122
F3UT3C5000495
P-3122
F3UT3C4000059
P-3123
QBDA1C7000402

If the FIRST P number entry has a serial number then it errors.
If the data starts with two non serial numbered P numbers it works fine.

I tried starting the error producing data in A2 and it worked but produces an error 400 AFTER the data is correctly handled on the sheet.

These are the codes I am using which have a few minor additions to what you wrote.

Thanks.
Howard


Option Explicit
Option Base 1

Sub MyScanA1()
'/ by Claus

Dim LRow As Long
Dim MyArr As Variant
Dim MyArr1 As Variant
Dim arrOut() As Variant
Dim i As Long, j As Long
Dim myCt As Long

Range("B:E").ClearContents

LRow = Cells(Rows.Count, 1).End(xlUp).Row

MyArr = Range("A2:A" & LRow)
myCt = WorksheetFunction.CountIf(Range("A2:A" & LRow), "P" & "*")

j = 1
For i = LBound(MyArr) To UBound(MyArr)

ReDim Preserve arrOut(myCt, 2)
If Left(MyArr(i, 1), 1) = "P" Then

arrOut(j, 1) = MyArr(i, 1)

j = j + 1

Else
arrOut(j - 1, 2) = MyArr(i, 1)

End If
Next

Range("A2:B" & LRow).ClearContents

Range("A2").Resize(UBound(arrOut), 2) = arrOut

'
ReScan
ClearLocateReturn

End Sub


Sub ClearLocateReturn()
Dim MyArr As Variant

MyArr = Range("C1", Range("E1").End(xlDown)).Value

Range("A:E").ClearContents

Range("A1").Resize(UBound(MyArr, 1), UBound(MyArr, 2)) = MyArr
End Sub


And in a standard module:

Option Explicit

Sub ReScan()
Dim LRow1 As Long, LRow2 As Long
Dim arrIn As Variant
Dim arrOut() As Variant
Dim MyArr As Variant
Dim dic As Object
Dim i As Long

'/Modify the sheet name
With Sheets("Sheet1")
LRow1 = .Cells(.Rows.Count, 1).End(xlUp).Row
arrIn = .Range("A1:B" & LRow1)
Set dic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(arrIn, 1)
dic.Item(arrIn(i, 1)) = arrIn(i, 1)
Next

MyArr = dic.items
For i = 0 To UBound(MyArr)
ReDim Preserve arrOut(dic.Count - 1, 1)
arrOut(i, 0) = MyArr(i)
arrOut(i, 1) = WorksheetFunction.VLookup(arrOut(i, 0), _
.Range("A1:B" & LRow1), 2, 0)
Next
.Range("C1").Resize(dic.Count, 2) = arrOut
LRow2 = .Cells(.Rows.Count, 3).End(xlUp).Row
With .Range("E1:E" & LRow2)
.Formula = "=SumProduct(--($A$1:$A$" & LRow1 & _
"=C1),--($B$1:$B$" & LRow1 & "= D1))"
.Value = .Value
End With
End With
End Sub
 
Hi Howard,

Am Mon, 24 Feb 2014 22:21:57 -0800 (PST) schrieb L. Howard:
P-3122
F3UT2BA000457 <note serial number here>
P-3122
F3UT3C5000495
P-3122
F3UT3C4000059
P-3123
QBDA1C7000402
Click to expand...

you are in the wrong thread ;-)

Your data starts in A1. Option Base 1 is NOT needed for the following
macro:

Sub MyScan5()
Dim LRow As Long
Dim myArr As Variant
Dim arrOut() As Variant
Dim i As Long, j As Long
Dim myCt As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row

myArr = Range("A1:A" & LRow)
myCt = WorksheetFunction.CountIf(Range("A1:A" & LRow), "P" & "*")

For i = LBound(myArr) To UBound(myArr)
ReDim Preserve arrOut(myCt - 1, 1)
If Left(myArr(i, 1), 1) = "P" Then
arrOut(j, 0) = myArr(i, 1)
j = j + 1
Else
arrOut(j - 1, 1) = myArr(i, 1)
End If
Next

Range("A1:B" & LRow).ClearContents
Range("A1").Resize(UBound(arrOut) + 1, 2) = arrOut

End Sub


Regards
Claus B.
 
Hi Howard,

Am Mon, 24 Feb 2014 22:21:57 -0800 (PST) schrieb L. Howard:
P-3122
F3UT2BA000457 <note serial number here>
P-3122
F3UT3C5000495
P-3122
F3UT3C4000059
P-3123
QBDA1C7000402
Click to expand...

which macro errors out? The macro to put serial number to column B or
the macro for the unique values?
The first one I fixed with the last answer. The second one errors out if
you use the Test_CB because the unique values are created only from
column A. And in your case you only get 2 values back. I fixed it with
Test_CB4 and and Test_CB_2_2. I wrote this in an earlier answer.
Please have another look:
https://onedrive.live.com/?cid=9378...#cid=9378AAB6121822A3&id=9378AAB6121822A3!326
for "UniqueValues" and look at the comments.

P.S.: SkyDrive changed to OneDrive. You can bookmark the link to
OneDrive if you use it often.


Regards
Claus B.
 
<which macro errors out? The macro to put serial number to column B or
<the macro for the unique values?

The one moving the serial number to column B.

I'll have a look at OneDrive.

Howard
 
Hi Howard,



Am Tue, 25 Feb 2014 01:06:48 -0800 (PST) schrieb L. Howard:






you can also look for

"ScanValues"





Regards

Claus B.

--
Click to expand...

Hi Claus,

It looks like running MyScan5 with a call to Test_CB4 does it all.

I'll look at Scan Values too.

Thanks.

Howard
 
Hi Claus,
It looks like running MyScan5 with a call to Test_CB4 does it all.



I'll look at Scan Values too.



Thanks.



Howard
Click to expand...

Also MyScan5 and Test_CB looks like it gets it done too.

Howard
 
Hi Howard,

Am Tue, 25 Feb 2014 01:48:37 -0800 (PST) schrieb L. Howard:
Also MyScan5 and Test_CB looks like it gets it done too.
Click to expand...

I wrote Test_CB because I thought the values in A are unique. As you
posted another example and there are same values in A with different
values in B I found that error. So the unique values are created only
from A some values are missing. In "UniqueValues" you see that 2 values
are missing. All other macros write 9 values, CB_Test only 7.
For your data that macro is wrong.

For this case I wrote Test_CB4 and Test_CB2_2.
CB2_2 works with RemoveDuplicates and is faster.
In "ScanValues" works a combination of Scan5 and TestCB2_2


Regards
Claus B.
 
Hi Claus,

Because some of the serial numbers just happen to start with "P" but NO serial number will state with "P-", I made that change in the code.

That errors out this line with a subscript out of range.

arrOut(j - 1, 1) = myArr(i, 1)

I made some random changes of the -1 and the other 1's but nothing worked.


myCt = WorksheetFunction.CountIf(.Range("A1:A" & LRow), "P-" & "*")

For i = LBound(myArr) To UBound(myArr)
ReDim Preserve arrOut(myCt - 1, 1)
If Left(myArr(i, 1), 1) = "P-" Then
arrOut(j, 0) = myArr(i, 1)
j = j + 1
Else

arrOut(j - 1, 1) = myArr(i, 1)

End If
Next

Howard
 
TYPO...

<NO serial number will state with "P-",

NO serial number will START with "P-",

H'wd
 
Back
Top