Reduce duplicates to 1 with a count of how many before

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

L. Howard

I was surprised to find three or four code samples that did a similar thing as below, but was unable to adapt the monsters to my sheet.

Here is what I want to do.
With columns A & B:

Change this

GL14 x
GL15
GL15
GL15
GL16 x
GL17
GL17


to this

GL14 x
GL15 3
GL16 x
GL17 2

Where: if there is text in column B leave A and B as is.
Where: there were three GL15's before, reduce to one GL15 with a count of how may there was to begin with.

The codes I could find were pretty much multiple employee ID numbers in A and hours worked in B, then add all the hours for same ID and return a single ID in A and the total hours for that ID in B.

Thanks.
Howard
 
Hi Howard,

Am Fri, 21 Feb 2014 21:46:36 -0800 (PST) schrieb L. Howard:
Change this

GL14 x
GL15
GL15
GL15
GL16 x
GL17
GL17


to this

GL14 x
GL15 3
GL16 x
GL17 2
Click to expand...

try:

Option Explicit
Option Base 1

Sub Test_CB()
Dim LRow As Long
Dim arrIn As Variant
Dim arrOut() As Variant
Dim myArr As Variant
Dim dic As Object
Dim i As Long

LRow = Cells(Rows.Count, 1).End(xlUp).Row
arrIn = Range("A1:B" & LRow)
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, 2)
arrOut(i + 1, 1) = myArr(i)
With WorksheetFunction
If .VLookup(myArr(i), Range("A1:B" & LRow), 2, 0) = 0 Then
arrOut(i + 1, 2) = .CountIf(Range("A1:A" & LRow), myArr(i))
Else
arrOut(i + 1, 2) = .VLookup(myArr(i), Range("A1:B" & LRow),
2, 0)
End If
End With
Next
Range("C1").Resize(dic.Count, 2) = arrOut
End Sub

The code will give you unique values and the number of these values in
column C:D


Regards
Claus B.
 
Hi Howard,

Am Sat, 22 Feb 2014 10:31:47 +0100 schrieb Claus Busch:
Sub Test_CB()
Click to expand...

or write the values from sheet1 without duplicates to sheet2 and
calculate the number of occurence:

Sub Test_CB2()
Dim LRow As Long
Dim myArr As Variant
Dim rngC As Range

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

With Sheets("Sheet2")
.Range("A1").Resize(LRow, 2) = myArr
.Range("A1:B" & LRow).RemoveDuplicates _
Columns:=Array(1, 2), Header:=xlNo
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For Each rngC In .Range("B1: B" & LRow)
If Len(rngC) = 0 Then
rngC = WorksheetFunction.CountIf(Sheets("Sheet1") _
.Range("A1:A" & LRow), rngC.Offset(, -1))
End If
Next
End With
End Sub


Regards
Claus B.
 
Hi Howard,

Am Sat, 22 Feb 2014 11:10:52 +0100 schrieb Claus Busch:

found an error. Try instead
Sub Test_CB2()
Click to expand...

found an error. Try instead

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

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

With Sheets("Sheet2")
.Range("A1").Resize(LRow1, 2) = myArr
.Range("A1:B" & LRow1).RemoveDuplicates _
Columns:=Array(1, 2), Header:=xlNo
LRow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
For Each rngC In .Range("B1: B" & LRow2)
If Len(rngC) = 0 Then
rngC = WorksheetFunction.CountIf(Sheets("Sheet1") _
.Range("A1:A" & LRow1), rngC.Offset(, -1))
End If
Next
End With
End Sub


Regards
Claus B.
 
Hi Howard,
Click to expand...
found an error. Try instead
Click to expand...


Hi Claus,

The Test_CB is excellent!!
A work of art to me.

The Test_CB2 is puzzling to me. Not sure what the results should look like.

If I run the code on this data on sheet 1

P-1
P-2
P-3 x
P-5
P-6
P-7 x
P-8
P-9
P-10 x
P-1
P-2
P-3 x
P-5
P-6
P-7 x
P-8
P-9
P-10 x


I get this on sheet 2.

P-1
P-2
P-3 x
P-5
P-6
P-7 x
P-8
P-9
P-10 x
P-1
P-2
P-3 x
P-5
P-6
P-7 x
P-8
P-9
P-10 x
#N/A #N/A

And an error alert Invalid procedure call or argument

I did change all the A1's and B1's to A2's and B2's to avoid headers. Did the same with Test_CB and it works well.

Howard
 
Hi Howard,

Am Sat, 22 Feb 2014 06:47:12 -0800 (PST) schrieb L. Howard:
The Test_CB2 is puzzling to me. Not sure what the results should look like.
Click to expand...

in the first answer Test_CB2 has an error
I tried your example with the second answer and the fixed error and I
get:
P-1 2
P-2 2
P-3 x
P-5 2
P-6 2
P-7 x
P-8 2
P-9 2
P-10 x



Regards
Claus B.
 
Hi Howard,

Am Sat, 22 Feb 2014 06:47:12 -0800 (PST) schrieb L. Howard:
P-1
P-2
P-3 x
P-5
P-6
P-7 x
P-8
P-9
P-10 x
P-1
P-2
P-3 x
P-5
P-6
P-7 x
P-8
P-9
P-10 x
Click to expand...

in your first posting you wrote you want to keep the values in A if B
has text.
How about your example? Do you want to keep P3 or P7 two times?


Regards
Claus B.
 
Hi Howard,



Am Sat, 22 Feb 2014 06:47:12 -0800 (PST) schrieb L. Howard:






in the first answer Test_CB2 has an error

I tried your example with the second answer and the fixed error and I

get:

P-1 2

P-2 2

P-3 x

P-5 2

P-6 2

P-7 x

P-8 2

P-9 2

P-10 x







Regards

Claus B.

--
Click to expand...

Hi Claus,

This would be great for a sheet 2 result, really it is the same as a sheet 1 isn't it?

Not sure why my book won't do that??
I tried your example with the second answer and the fixed error and I
get:
P-1 2
P-2 2
P-3 x
P-5 2
P-6 2
P-7 x
P-8 2
P-9 2
P-10 x
Click to expand...


Howard
 
Hi Howard,



Am Sat, 22 Feb 2014 07:44:14 -0800 (PST) schrieb L. Howard:






the result is the same as in sheet1.

Please have a look:

https://skydrive.live.com/#cid=9378AAB6121822A3&id=9378AAB6121822A3!326

for "UniqueValues"



There are 3 macros. The two you know and another one to keep all values

from A if in B is text.





Regards

Claus B.

--
Click to expand...

Hi Claus,

I do believe I got it figured out.

Test_CB2 doesn't like Option Base 1

All seems to be working fine now.

Not sure if Test_CB3 is needed, but I will indeed hang on to it.

Thanks Claus, your magic wand works once again. Nice indeed.

Regards,
Howard
 
Hi Howard,

Am Sat, 22 Feb 2014 08:42:19 -0800 (PST) schrieb L. Howard:
All seems to be working fine now.

Not sure if Test_CB3 is needed, but I will indeed hang on to it.
Click to expand...

if CB3 is not needed I would prefer CB
Like yesterday you can also delete column A:B if the array is filled and
write the array back to these columns


Regards
Claus B.
 
Hi Howard,



Am Sat, 22 Feb 2014 08:42:19 -0800 (PST) schrieb L. Howard:






if CB3 is not needed I would prefer CB

Like yesterday you can also delete column A:B if the array is filled and

write the array back to these columns





Regards

Claus B.

--

Win XP PRof SP2 / Vista Ultimate SP2

Office 2003 SP2 /2007 Ultimate SP2
Click to expand...

I like the results in C & D.

Howard
 
I like the results in C & D.



Howard
Click to expand...

A question, please.

Reference to Test_CB2 which returns results to sheet 2.
Would you know why if I change all the A1's and B1's to A2 and B2 in the code it would produce these results?

The bad data is the same number of rows as the good.

This A 14 row excerpt from the bottom of correctly returned data to the next 7 rows of some corrupt data.


P-3745 AA-1248
P-3746 2
P-3747 2
P-3748 AA-1249
P-3749 2
P-3750 2
P-3751 AA-1250
0
0
0
0
0
0
0

And this is the last entry of the bad data:

#N/A #N/A


Howard
 
Hi Howard,

Am Sat, 22 Feb 2014 10:56:51 -0800 (PST) schrieb L. Howard:
Reference to Test_CB2 which returns results to sheet 2.
Would you know why if I change all the A1's and B1's to A2 and B2 in the code it would produce these results?
Click to expand...

the duplicate in Row 15 will not be deleted. You have to change LRow1 to
LRow1 + 1:
With Sheets("Sheet2")
.Range("A2").Resize(LRow1, 2) = myArr
.Range("A2:B" & LRow1 + 1).RemoveDuplicates _
Columns:=Array(1, 2), Header:=xlNo


Regards
Claus B.
 
Hi Howard,



Am Sat, 22 Feb 2014 10:56:51 -0800 (PST) schrieb L. Howard:







the duplicate in Row 15 will not be deleted. You have to change LRow1 to

LRow1 + 1:

With Sheets("Sheet2")

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

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

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





Regards

Claus B.

--
Click to expand...


I would have never found that. Now it does the work it's supposed to do but ends with the pair of #N/A's and type mismatch error pop up.

I'm lost again on what to look for. The usual suspects like dimming a string as a long or referring to a sheet that doesn't exist etc. are not apparent to me here, but I will keep looking.

Howard
 
Hi Howard,

Am Sat, 22 Feb 2014 12:04:37 -0800 (PST) schrieb L. Howard:
I would have never found that. Now it does the work it's supposed to do but ends with the pair of #N/A's and type mismatch error pop up.
Click to expand...

have another look in SkyDrive. I changed the data to your last example
and for CB2 all rows(1) to rows(2)


Regards
Claus B.
 
Hi Howard,



Am Sat, 22 Feb 2014 12:04:37 -0800 (PST) schrieb L. Howard:






have another look in SkyDrive. I changed the data to your last example

and for CB2 all rows(1) to rows(2)





Regards

Claus B.

--
Click to expand...
Hi Claus,

I do believe it is all anchored down and running fine.

Sure do appreciate it.

Howard
 
Hi Claus,

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

Count the number of identical P-xxxx's with nothing in column B next to them and the number of identical P-xxxx's with ABCxxxx in column B next to them.

P-1234 ABC and P-1234 ABC would be 2.
P-4567 DEF and P-4567 HIJ would be 1 for each.
P-1357 XXX and P-1388 XXX would be 1 for each.

Those sum go in column C.

P-4352
P-3534
P-4568
ABCDE123
P-3333
P-5506
CDEFG234
P-4352
P-3534
P-4568
ABCDE124
P-7679
P-9852


P-9876 ABCDE 1
P-5678 FGRTTTRGF 1
P-7675 HFHFHFH 1
P-8901 ABCDE 1
P-8901 4
P-3456 1
P-6543 2
P-54463 1

The item in column B is a "serial number" so most likely all the P-xxxx with a
serial number in column C will be 1. But if you have a couple or three
P-9876 ABCDE's, for example, then that number should be in column C.

Notice P-8901 ABCDE and P-8901 are counted separate.

Once the count is completed then the duplicates can be removes to show as the column A, B, C example.

The data above shows format only. None of the final outcome data is actually part of the raw data. It is just a before and after view so to speak.

This is my last shot at this caper, I feel I've abused the privilege of the news group and your patience too much.

Thanks.

Howard
 
Back
Top