Do not count accounts without an active number in cell..

[=HPSF=RMP]

A1:200 = formula =T(Sheet2!A2).
Basically I am bringing the text over from Sheet 2 to Sheet 1 A1:A200

Below is the formula i'm using. Its automatically counts the Total entries and the Total duplicates. The problem i'm having is instead of counting the value that carries over from sheet 2 its counting the formula in sheet 1. I want it to only count the value that is carried over and ignore the formula in A1:A200 if the value isnt carried over and the cell is left blank.

Is this possible?

thanks

Sub RemoveDuplicates()
Dim AllCells As Range, Cell As Range
Dim NoDupes As New Collection
Dim i As Integer, j As Integer
Dim Swap1, Swap2, Item

' The items are in A1:A200
Set AllCells = Range("A1:A200")

' The next statement ignores the error caused
' by attempting to add a duplicate key to the collection.
' The duplicate is not added - which is just what we want!
On Error Resume Next
For Each Cell In AllCells
NoDupes.Add Cell.Value, CStr(Cell.Value)
' Note: the 2nd argument (key) for the Add method must be a string
Next Cell

' Resume normal error handling
On Error GoTo 0

' Update the labels on UserForm1
With UserForm1
.Label1.Caption = "Total Accounts: " & AllCells.Count
.Label2.Caption = "Unique Accounts: " & NoDupes.Count
End With

' Sort the collection (optional)
For i = 1 To NoDupes.Count - 1
For j = i + 1 To NoDupes.Count
If NoDupes(i) > NoDupes(j) Then
Swap1 = NoDupes(i)
Swap2 = NoDupes(j)
NoDupes.Add Swap1, before:=j
NoDupes.Add Swap2, before:=i
NoDupes.Remove i + 1
NoDupes.Remove j + 1
End If
Next j
Next i

' Add the sorted, non-duplicated items to a ListBox
For Each Item In NoDupes
UserForm1.ListBox1.AddItem Item
Next Item

' Show the UserForm
UserForm1.Show
End Sub

 

[Andrew Poulsom]

Try this:

Sub RemoveDuplicates() 
   Dim AllCells As Range, Cell As Range 
   Dim TotCount as Long
   Dim NoDupes As New Collection 
   Dim i As Integer, j As Integer 
   Dim Swap1, Swap2, Item 

' The items are in A1:A200 
   Set AllCells = Range("A1:A200") 

' The next statement ignores the error caused 
' by attempting to add a duplicate key to the collection. 
' The duplicate is not added - which is just what we want! 
   On Error Resume Next 
   For Each Cell In AllCells 
      If Cell.Value <> "" Then
         NoDupes.Add Cell.Value, CStr(Cell.Value) 
' Note: the 2nd argument (key) for the Add method must be a string 
         TotCount = TotCount + 1
      End If
   Next Cell 

' Resume normal error handling 
   On Error GoTo 0 

' Update the labels on UserForm1 
   With UserForm1 
      .Label1.Caption = "Total Accounts: " & TotCount 
      .Label2.Caption = "Unique Accounts: " & NoDupes.Count 
   End With 

' Sort the collection (optional) 
   For i = 1 To NoDupes.Count - 1 
      For j = i + 1 To NoDupes.Count 
         If NoDupes(i) > NoDupes(j) Then 
            Swap1 = NoDupes(i) 
            Swap2 = NoDupes(j) 
            NoDupes.Add Swap1, before:=j 
            NoDupes.Add Swap2, before:=i 
            NoDupes.Remove i + 1 
            NoDupes.Remove j + 1 
         End If 
      Next j 
   Next i 

' Add the sorted, non-duplicated items to a ListBox 
   For Each Item In NoDupes 
      UserForm1.ListBox1.AddItem Item 
   Next Item 

' Show the UserForm 
   UserForm1.Show 
End Sub

 

[=HPSF=RMP]

PErfect!
thanks again!