Results 1 to 3 of 3
  1. #1
    Star Lounger
    Join Date
    Aug 2001
    Location
    St. Louis, Missouri, USA
    Posts
    67
    Thanks
    3
    Thanked 0 Times in 0 Posts

    List of records with unique entries in one column

    I have a sheet with about 35,000 rows and about 20 columns. What I would like to do is find each unique value in column A (maybe the first one to keep it simple) and copy that whole row. I hope the attached file makes it clear. I'm using Excel 2010.

    Many thanks,

    lind
    Attached Files Attached Files

  2. #2
    Super Moderator RetiredGeek's Avatar
    Join Date
    Mar 2004
    Location
    Manning, South Carolina
    Posts
    9,435
    Thanks
    372
    Thanked 1,457 Times in 1,326 Posts
    Lind,

    This code should meet your needs. One caveat is the the source data MUST be sorted by Col A1
    You could write code to do it in its current unsorted mode {your example data} but it would be much more complicated.
    Code:
    Option Explicit
    
    Sub CopyUnique()
    
       Dim lLast    As Long
       Dim lOffset  As Long
       Dim shtDest  As Worksheet
       Dim shtSrc   As Worksheet
       
       Application.ScreenUpdating = False
       lLast = 0
       lOffset = 1
       Set shtDest = Sheets("UniqueData")
       Set shtSrc = Sheets("SourceData")
       [a2].Select
       shtDest.Activate
       '*** Clear Destination Sheet Except for Headers ***
       Range("A2").Select
       Range(Selection, Selection.End(xlDown)).Select
       Range(Selection, Selection.End(xlToRight)).ClearContents
       [a2].Select
       shtSrc.Activate          '*** Return to Source Sheet
       
       '*** Copy First Row ***
       ActiveCell.EntireRow.Copy
       shtDest.Paste
       Application.CutCopyMode = False
       
       With ActiveCell
       
           Do While .Offset(lOffset, 0).Value <> ""
           
             Do While .Offset(lOffset, 0).Value <> "" And _
                      .Offset(lOffset, 0).Value = .Offset(lLast).Value
               lOffset = lOffset + 1
             Loop
           
             If .Offset(lOffset, 0).Value <> "" Then 'Copy Record
               .Offset(lOffset, 0).EntireRow.Copy
               shtDest.Activate
               ActiveCell.Offset(1, 0).Select      'Move to empty row
               shtDest.Paste
               Application.CutCopyMode = False
               shtSrc.Activate
               lLast = lOffset
               lOffset = lOffset + 1
             End If
             
           Loop
       
       End With 'Activecell
       
    End Sub     'CopyUnique()
    Test file attached:
    Attached Files Attached Files
    May the Forces of good computing be with you!

    RG

    PowerShell & VBA Rule!

    My Systems: Desktop Specs
    Laptop Specs

  3. #3
    Star Lounger
    Join Date
    Aug 2001
    Location
    St. Louis, Missouri, USA
    Posts
    67
    Thanks
    3
    Thanked 0 Times in 0 Posts
    Thanks, Retired Geek. Just what I needed!

    lind

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •