Eliminating repeats from a list

  • Thread starter Thread starter sycsummit
  • Start date Start date
S

sycsummit

I am using Excel 2003. I am working with a list of names of various people,
in one column. I need to have this list reproduced on a blank worksheet with
the repeated names removed.

for instance, the list I'm working with would be something like:
Pat
Pat
Dan
Marie
Marie
Sharron
Sharron
Sharron
Sharron
Daniel
Mark
Mark
Mark
Mark

....and I would need this list to be reproduced on another tab as:
Pat
Dan
Marie
Sharron
Daniel
Mark

Is there a way I can do this?
 
I am using Excel 2003.  I am working with a list of names of various people,
in one column.  I need to have this list reproduced on a blank worksheetwith
the repeated names removed.

for instance, the list I'm working with would be something like:
Pat
Pat
Dan
Marie
Marie
Sharron
Sharron
Sharron
Sharron
Daniel
Mark
Mark
Mark
Mark

...and I would need this list to be reproduced on another tab as:
Pat
Dan
Marie
Sharron
Daniel
Mark

Is there a way I can do this?
Click to expand...

Yes, there is a way!

Paste this into a new module and hit F5:


'Code
Option Explicit

Public Sub CountDuplicates()

'Declarations
Dim strCellText() As String
Dim strCellUnique() As String

Dim Cell As Range
Dim iCounter As Integer
Dim jCounter As Integer
Dim iNumCells As Integer
Dim iNumDups As Integer
Dim MSG As String
Dim bnDup As Boolean
Dim strSheetName As String
Dim strNewName As String


'Get array of all unique values
iCounter = 1
For Each Cell In Selection

bnDup = False
ReDim Preserve strCellText(iCounter)
strCellText(iCounter) = Cell

For jCounter = 1 To iNumCells
If strCellText(iCounter) = strCellText(jCounter) Then
bnDup = True
End If
Next jCounter

If bnDup = False Then
iNumCells = iNumCells + 1
ReDim Preserve strCellUnique(iNumCells)
strCellUnique(iNumCells) = Cell
End If

iCounter = iCounter + 1
Next Cell


'Get sheet names
strSheetName = ActiveWorkbook.ActiveSheet.Name
strNewName = "NewSheet" & CStr(ActiveWorkbook.Worksheets.Count)

'See if sheet exists, create if it doesn't
If WorksheetExists(strNewName, ActiveWorkbook) Then
Call MsgBox("Rename sheet " & strNewName & ".", vbOKOnly,
"Error")
Exit Sub
Else

ActiveWorkbook.Worksheets.Add.Name = strNewName
Sheets(strNewName).Move
After:=Sheets(ActiveWorkbook.Worksheets.Count)
End If

'Copy and paste
Sheets(strNewName).Activate

For iCounter = 1 To iNumCells
Cells(iCounter, 1) = strCellUnique(iCounter)
Next iCounter



End Sub
Function WorksheetExists(SheetName As String, Optional WhichBook As
Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function

'End of code


HTH

Chris
 
Here is some code that I use. It requires a reference to the Microsoft
Scripting Runtime library. In the VBE Tools -> References -> check Microsoft
Scripting Runtime.

Private Sub GetUniqueItems()
Dim cell As Range 'Current cell in range to check
Dim rngToSearch As Range 'Cells to be searched
Dim dic As Scripting.Dictionary 'Dictionary Object
Dim dicItem As Variant 'Items within dictionary object
Dim wks As Worksheet 'Worksheet to populate with
unique items
Dim rngPaste As Range 'Cells where unique items are
placed

Application.ScreenUpdating = False
'Create range to be searched
Set rngToSearch = Intersect(ActiveSheet.UsedRange, Selection)
If rngToSearch Is Nothing Then Set rngToSearch = ActiveCell

'Confirm there is a relevant range selected
If Not rngToSearch Is Nothing Then
'Create dictionay object
Set dic = New Scripting.Dictionary

'Populate dictionary object with unique items (use key to define
unique)
For Each cell In rngToSearch 'Traverse selected range
If Not dic.Exists(cell.Value) And cell.Value <> Empty Then
'Check the key
dic.Add cell.Value, cell.Value 'Add the item if unique
End If
Next

If Not dic Is Nothing Then 'Check for dictionary
Set wks = Worksheets.Add 'Create worksheet to populate
Set rngPaste = wks.Range("A1") 'Create range to populate
For Each dicItem In dic.Items 'Loop through dictionary
rngPaste.NumberFormat = "@" 'Format cell as text
rngPaste.Value = dicItem 'Add items to new sheet
Set rngPaste = rngPaste.Offset(1, 0) 'Increment paste range
Next dicItem
'Clean up objects
Set wks = Nothing
Set rngPaste = Nothing
Set dic = Nothing
End If
End If
Application.ScreenUpdating = True
End Sub
 
Sorry... to use the code I posted just select the column that the names are
in and run the code.
 
I believe this macro will do what you want...

Sub MoveUniqueNames()
Dim X As Long
Dim Z As Long
Dim UniqueNames As String
UniqueNames = "*"
Z = 1
With Worksheets("Sheet1")
For X = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
If InStr(UniqueNames, "*" & .Cells(X, "A").Value & "*") = 0 Then
UniqueNames = UniqueNames & .Cells(X, "A").Value & "*"
Worksheets("Sheet2").Cells(Z, "A").Value = .Cells(X, "A").Value
Z = Z + 1
End If
Next
End With
End Sub

It assumes the worksheet with your original (repeated) name list is Sheet1
(in Column A starting at Row 1) and the worksheet you want to put the unique
name list on is Sheet2 (into Column A starting at Row 1).

Rick
 
All of these responses look impressive, but I was hoping there would be a
more simple solution, such as a function I may have overlooked... anything
that would let me type "=(formula)" in the cell and be done with it.

I can work with this though... but where do you put this? How do I input
this stuff into my spreadsheet?
 
All of these responses look impressive, but I was hoping there would be a
more simple solution, such as a function I may have overlooked... anything
that would let me type "=(formula)" in the cell and be done with it.

I can work with this though... but where do you put this? How do I input
this stuff into my spreadsheet?
 
This response works with my code... I did not check it against the other
postings. If you are not already in the VB editor, press Alt+F11 from any
worksheet to go there. Once there, click on Insert/Module from the VB editor
menu bar and then Copy/Paste my code (repeated here for your convenience)

Sub MoveUniqueNames()
Dim X As Long
Dim Z As Long
Dim UniqueNames As String
UniqueNames = "*"
Z = 1
With Worksheets("Sheet1")
For X = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
If InStr(UniqueNames, "*" & .Cells(X, "A").Value & "*") = 0 Then
UniqueNames = UniqueNames & .Cells(X, "A").Value & "*"
Worksheets("Sheet4").Cells(Z, "A").Value = .Cells(X, "A").Value
Z = Z + 1
End If
Next
End With
End Sub

into the code window that opened there. You can execute the code from any
worksheet, but my guess is you will want to be in Sheet2 (where my code
places the unique names that are listed in Sheet1 starting at Column A, Row
1) in order to see the list being produced; so, go to Sheet2 and then press
Alt+F8 and select MoveUniqueNames from the list, then click on Run. You
should see the unique names listed on Sheet2 starting at Column A, Row 1.

Rick
 
Thanks for the direction... I get the concept. But, I am unfamiliar with
this language and syntax!

How would I have to change your code if I wanted to read the whole list of
names from a worksheet titled "NEW", from cells J1 through J25 -- and paste
them in a worksheet called "Billing", as my list of one of each name,
starting with cell A5?
 
I generalized the code so you can modify it easily in the future in that
need should ever arise. There are 6 constant (Const) statements toward the
top of the code that controls where the names will be read from and where
they will be written to. The Const names should be fairly self-explanatory,
so you should be able to change the setup at will. One comment on your "J1
through J25" statement. The code, as written, does not need to know how many
names there are in the list... it will read down to the last filled-in cell
in the SourceColumn.

Rick

Sub MoveUniqueNames()
Dim X As Long
Dim Z As Long
Dim UniqueNames As String
Const SourceColumn As String = "J"
Const SourceStartRow As Long = 1
Const DestinationColumn As String = "A"
Const DestinationStartRow As Long = 5
Const SourceSheet As String = "NEW"
Const UniqueSheet As String = "Billing"
UniqueNames = "*"
Z = DestinationStartRow
With Worksheets(SourceSheet)
For X = SourceStartRow To .Cells(.Rows.Count, _
SourceColumn).End(xlUp).Row
If .Cells(X, SourceColumn) <> "" Then
If InStr(UniqueNames, "*" & _
.Cells(X, SourceColumn).Value & "*") = 0 Then
UniqueNames = UniqueNames & .Cells(X, SourceColumn).Value & "*"
Worksheets(UniqueSheet).Cells(Z, DestinationColumn).Value = _
.Cells(X, SourceColumn).Value
Z = Z + 1
End If
End If
Next
End With
End Sub
 
Yes! This works great!

BUT- now I have a new problem! from the source sheet ("NEW"), there is a
monetary total next to each name. How would I go about summing up all totals
for the same name and having this total come up next to the corresponding
name on the destination sheet ("Billing")? Ie, if my NEW sheet looks like:

mike 7.50
mike 6.00
mike 3.00
lou 2.00
lou 1.50
etc

how would I change the Billing sheet to just output this as:
mike 16.50
lou 3.50
etc

?

This may actually get more complicated as I continue to try to automate my
form, but I'm hoping that if I see enough of these code snippets I'll pick up
 
Replace the code I gave you earlier with the code below (note that I added
two more Const statements for the money source and destination columns).

Rick

Sub MoveUniqueNames()
Dim X As Long
Dim Y As Long
Dim Z As Long
Dim LastCell As Long
Dim Total As Double
Dim UniqueNames As String
Const SourceColumn As String = "J"
Const SourceStartRow As Long = 1
Const DestinationColumn As String = "A"
Const DestinationStartRow As Long = 5
Const SourceMoneyColumn As String = "K"
Const DestinationMoneyColumn As String = "B"
Const SourceSheet As String = "NEW"
Const UniqueSheet As String = "Billing"
UniqueNames = "*"
Z = DestinationStartRow
With Worksheets(SourceSheet)
LastCell = .Cells(.Rows.Count, SourceColumn).End(xlUp).Row
For X = SourceStartRow To LastCell
If .Cells(X, SourceColumn) <> "" Then
If InStr(UniqueNames, "*" & _
.Cells(X, SourceColumn).Value & "*") = 0 Then
UniqueNames = UniqueNames & .Cells(X, SourceColumn).Value & "*"
Worksheets(UniqueSheet).Cells(Z, DestinationColumn).Value = _
.Cells(X, SourceColumn).Value
Z = Z + 1
End If
End If
Next
For X = DestinationStartRow To Z - 1
Total = 0
For Y = SourceStartRow To LastCell
If .Cells(Y, SourceColumn).Value = Worksheets(UniqueSheet). _
Cells(X, DestinationColumn).Value Then
Total = Total + .Cells(Y, SourceMoneyColumn).Value
End If
Next
Worksheets(UniqueSheet).Cells(X, DestinationMoneyColumn).Value = Total
Next
End With
End Sub
 
Rick-

Thanks again for your help! This is going to save me soooo much time at work!

One other question, is it possible to get the script to run all the time?
Ie, so i don't have to hit alt-f8 and run it when I want to print out a
billing report? If it would, say, access this information every time I
clicked on the "billing" tab, that'd be sweet. Let me know... Thanks again
for everything!
 
Delete the MoveUniqueNames subroutine (unless you think you will ever want
to run the code independently; that is, without going to the Billing sheet
in order to make it run) and go to the code window for the Billing sheet
(the easiest way to do that is right-click the tab for the Billing sheet and
select View Code from the popup menu) and Copy/Paste the event procedure
after my signature into that code window. After you have done that, the code
will run whenever you click on the Billing tab when a different sheet is
active. That means, you can make changes to the NEW sheet and by clicking on
the Billing sheet's tab, you will activate the code and go to the Billing
sheet at the same time.

Rick

Private Sub Worksheet_Activate()
Dim X As Long
Dim Y As Long
Dim Z As Long
Dim LastCell As Long
Dim Total As Double
Dim UniqueNames As String
Const SourceColumn As String = "J"
Const SourceStartRow As Long = 1
Const DestinationColumn As String = "A"
Const DestinationStartRow As Long = 5
Const SourceMoneyColumn As String = "K"
Const DestinationMoneyColumn As String = "B"
Const SourceSheet As String = "NEW"
Const UniqueSheet As String = "Billing"
UniqueNames = "*"
Z = DestinationStartRow
Worksheets(UniqueSheet).Range(DestinationColumn & ":" & _
DestinationColumn).Clear
Worksheets(UniqueSheet).Range(DestinationMoneyColumn & ":" & _
DestinationMoneyColumn).Clear
With Worksheets(SourceSheet)
LastCell = .Cells(.Rows.Count, SourceColumn).End(xlUp).Row
For X = SourceStartRow To LastCell
If .Cells(X, SourceColumn) <> "" Then
If InStr(UniqueNames, "*" & _
.Cells(X, SourceColumn).Value & "*") = 0 Then
UniqueNames = UniqueNames & .Cells(X, SourceColumn).Value & "*"
Worksheets(UniqueSheet).Cells(Z, DestinationColumn).Value = _
.Cells(X, SourceColumn).Value
Z = Z + 1
End If
End If
Next
For X = DestinationStartRow To Z - 1
Total = 0
For Y = SourceStartRow To LastCell
If .Cells(Y, SourceColumn).Value = Worksheets(UniqueSheet). _
Cells(X, DestinationColumn).Value Then
Total = Total + .Cells(Y, SourceMoneyColumn).Value
End If
Next
Worksheets(UniqueSheet).Cells(X, _
DestinationMoneyColumn).Value = Total
Next
End With
End Sub
 
Okay... I copied the code there and changed the constants to match with what
I've got as the starting cells for this data.

It's returning an error with the line:

Worksheets(UniqueSheet).Range(DestinationColumn & ":" & _
DestinationColumn).Clear

Not sure how to correct the problem, but the entire code as it is right now
reads as follows:

Private Sub Worksheet_Activate()
Dim X As Long
Dim Y As Long
Dim Z As Long
Dim LastCell As Long
Dim Total As Double
Dim UniqueNames As String
Const SourceColumn As String = "J"
Const SourceStartRow As Long = 4
Const DestinationColumn As String = "A"
Const DestinationStartRow As Long = 5
Const SourceMoneyColumn As String = "I"
Const DestinationMoneyColumn As String = "B"
Const SourceSheet As String = "NEW"
Const UniqueSheet As String = "Billing"
UniqueNames = "*"
Z = DestinationStartRow
Worksheets(UniqueSheet).Range(DestinationColumn & ":" & _
DestinationColumn).Clear
Worksheets(UniqueSheet).Range(DestinationMoneyColumn & ":" & _
DestinationMoneyColumn).Clear
With Worksheets(SourceSheet)
LastCell = .Cells(.Rows.Count, SourceColumn).End(xlUp).Row
For X = SourceStartRow To LastCell
If .Cells(X, SourceColumn) <> "" Then
If InStr(UniqueNames, "*" & _
.Cells(X, SourceColumn).Value & "*") = 0 Then
UniqueNames = UniqueNames & .Cells(X, SourceColumn).Value & "*"
Worksheets(UniqueSheet).Cells(Z, DestinationColumn).Value = _
.Cells(X, SourceColumn).Value
Z = Z + 1
End If
End If
Next
For X = DestinationStartRow To Z - 1
Total = 0
For Y = SourceStartRow To LastCell
If .Cells(Y, SourceColumn).Value = Worksheets(UniqueSheet). _
Cells(X, DestinationColumn).Value Then
Total = Total + .Cells(Y, SourceMoneyColumn).Value
End If
Next
Worksheets(UniqueSheet).Cells(X, _
DestinationMoneyColumn).Value = Total
Next
End With
End Sub

If you have an easy fix let me know, otherwise I'll just live with setting
up the macros manually; its not hard and WAY more convenient to the old way
of doing things. Thanks again,
Matt
 
Okay... I copied the code there and changed the constants to match with what
I've got as the starting cells for this data.

It's returning an error with the line:

Worksheets(UniqueSheet).Range(DestinationColumn & ":" & _
                               DestinationColumn).Clear

Not sure how to correct the problem, but the entire code as it is right now
reads as follows:

Private Sub Worksheet_Activate()
  Dim X As Long
  Dim Y As Long
  Dim Z As Long
  Dim LastCell As Long
  Dim Total As Double
  Dim UniqueNames As String
  Const SourceColumn As String = "J"
  Const SourceStartRow As Long = 4
  Const DestinationColumn As String = "A"
  Const DestinationStartRow As Long = 5
  Const SourceMoneyColumn As String = "I"
  Const DestinationMoneyColumn As String = "B"
  Const SourceSheet As String = "NEW"
  Const UniqueSheet As String = "Billing"
  UniqueNames = "*"
  Z = DestinationStartRow
  Worksheets(UniqueSheet).Range(DestinationColumn & ":" & _
                               DestinationColumn).Clear
  Worksheets(UniqueSheet).Range(DestinationMoneyColumn & ":" & _
                              DestinationMoneyColumn).Clear
  With Worksheets(SourceSheet)
    LastCell = .Cells(.Rows.Count, SourceColumn).End(xlUp).Row
    For X = SourceStartRow To LastCell
      If .Cells(X, SourceColumn) <> "" Then
        If InStr(UniqueNames, "*" & _
                 .Cells(X, SourceColumn).Value & "*") = 0 Then
          UniqueNames = UniqueNames & .Cells(X, SourceColumn).Value & "*"
          Worksheets(UniqueSheet).Cells(Z, DestinationColumn).Value = _
                                      .Cells(X, SourceColumn).Value
          Z = Z + 1
        End If
      End If
    Next
    For X = DestinationStartRow To Z - 1
      Total = 0
      For Y = SourceStartRow To LastCell
        If .Cells(Y, SourceColumn).Value = Worksheets(UniqueSheet). _
                             Cells(X, DestinationColumn).Value Then
          Total = Total + .Cells(Y, SourceMoneyColumn).Value
        End If
      Next
      Worksheets(UniqueSheet).Cells(X, _
                              DestinationMoneyColumn).Value = Total
    Next
  End With
End Sub

If you have an easy fix let me know, otherwise I'll just live with setting
up the macros manually; its not hard and WAY more convenient to the old way
of doing things.  Thanks again,
Matt

:





...

read more »- Hide quoted text -

- Show quoted text -
Click to expand...

Worksheets(UniqueSheet).Range(DestinationColumn & ":" &
DestinationColumn).Clear

Do you need quotes around the range? e.g. Range("A:V").Clear ?

Chris
 
I'm not sure what to tell you. I just set up a test worksheet naming two
sheets NEW and Billing and copied the code you said you are using into the
code window for the Billing worksheet. I then put a list of names in Column
J starting at Row 4 and a list of numbers in Column I also starting in Row 4
(both of these in the NEW worksheet). When I click on the tab for the
Billing worksheet, the previous unique listing of names and total monies on
the Billing worksheet is cleared and the new information is populated in
their places... no errors are generated.

You say you are getting an error with this line....
Worksheets(UniqueSheet).Range(DestinationColumn & ":" & _
DestinationColumn).Clear
Click to expand...

What is the exact error message you are getting. And what version of Excel
are you using?

Rick
 
It's saying "error: cannot change part of a merged cell"; then clicking
debug, it highlights the line I mentioned in my last post. Don't know if
it's somehow picking up the merged cells surrounding the source data, if one
of my constants is off by one (though I checked this...) or it's trying to
use the merged cells at the end of the data range as destination values, or
what... again, really not a big deal, but short of posting the file somewhere
I'm not sure how else to ask about this issue- which I can't really do
because of confidentiality policies where I work. If it ends here, I'm happy
to have gotten so much advice and input!

Thanks to all.
 
I personally do not use merged cells (they always seem to cause problems),
so I'm not sure if I'll be able to work around the problem for you or not
(depending on if the merged cells are behind it or not); however, I'm
willing to look. If you want to post the file somewhere so we can all see
it, that would be fine. You can also just send it to me directly if you want
(just remove the NO.SPAM stuff from my posted email address).

Rick
 
You must log in or register to reply here.

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Divide sheet into groups 2
sorting list to a new place` 3
Macro to run based on criteria 2
Excel Count Cells That Contain Text With "?" 0
Is there an easier way 4
Looping through delimited text and using VLOOKUP 5
Data Validation & Filtering Lists 3
Creating a que 5

Back
Top