Excel

Create a unique list and count of items from an unsorted list

Ease of Use

Easy

Version tested with

2000, 2003 

Submitted by:

mdmackillop

Description:

From a copied list of items (text or numbers), the code will create an ordered list of unique items, with a count of each alongside, and a total count below. 

Discussion:

The code was designed to summarise and sort "short" lists of sized items for pasting into another application. It may be too slow for lists in excess of 1,000 items, where a filter solution may be more appropriate. 

Code:

instructions for use

			

Option Explicit Option Compare Text Sub DupList() Dim DelCells As Long, Rw As Long, DupCount As Long, i As Long Dim Val1 As String, Val2 As String, SCell As String, ECell As String Application.ScreenUpdating = False 'Sort the selection into order Selection.Sort Key1:=ActiveCell, Order1:=xlAscending, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom DelCells = 0 'Count of deleted cells Rw = 0 'Offset count Val1 = ActiveCell.Value 'Initial value Do While Val1 <> "" DupCount = DupCount + 1 Val2 = ActiveCell.Offset(Rw).Formula Val1 = ActiveCell.Offset(Rw + 1).Formula 'If cell = cell below then delete latter. If Val1 = Val2 Then ActiveCell.Offset(Rw + 1).Delete Shift:=xlUp DelCells = DelCells + 1 Else 'If different, write count value and select next value ActiveCell.Offset(Rw, 1) = DupCount Rw = Rw + 1 DupCount = 0 End If Loop 'Add cells to replace those deleted With ActiveCell.End(xlDown).Offset(1) For i = 1 To DelCells .Insert Shift:=xlDown Next End With 'Add formula to total duplicate count SCell = ActiveCell.Offset(0, 1).AddressLocal(False, False) ECell = ActiveCell.End(xlDown).Offset(0, 1).AddressLocal(False, False) Range(ECell).Offset(1).Formula = "=SUM(" & SCell & ":" & ECell & ")" Application.ScreenUpdating = True End Sub

How to use:

  1. Open your Excel workbook
  2. Press Alt + F11 to open VBE.
  3. Insert-Module. (Insert -> module)
  4. Paste the code there in the window at right. (F7)
  5. Close VBE (Alt + Q or press the X in the top right hand corner).
  6. Save the file.
 

Test the code:

  1. Open the sample file
  2. Copy one of the lists and paste in a suitable location
  3. With the copy still selected, click on the button or press Alt+F8 and run the DupList macro
 

Sample File:

DupList.zip 10.93KB 

Approved by mdmackillop


This entry has been viewed 366 times.

Please read our Legal Information and Privacy Policy
Copyright @2004 - 2020 VBA Express