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

Whe if there is text in column B leave A and B as is.
Whe 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

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

Hi Howard,

Am Sat, 22 Feb 2014 10:31:47 +0100 schrieb Claus Busch:

Sub Test_CB()

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

Hi Howard,

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

found an error. Try instead
Sub Test_CB2()

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

On Saturday, February 22, 2014 2:14:44 AM UTC-8, Claus Busch wrote:
Hi Howard,

found an error. Try instead

Sub Test_CB2()


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.

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2

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

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.
--
Win XP PRof SP2 / Vista Ultimate SP2
Office 2003 SP2 /2007 Ultimate SP2