Copy Unique Values to New Sheet VBA

[nirvehex]

Hi all,

I'm working on a macro that will take my selected range (only what I have selected and may or may not be a filtered range) and copy the values to a new sheet and remove duplicates. Here is my code so far, but it's not quite working. it copying things that are filtered out. Any help would be appreciated, thank you!

Sub CopyUniqueValuesToNewSheet()
    Dim rng As Range
    Dim uniqueValues As Object
    Dim cell As Range
    Dim newSheet As Worksheet
    Dim newRow As Long
    
    ' Check if any range is selected
    If TypeName(Selection) <> "Range" Then
        MsgBox "No range selected!", vbExclamation
        Exit Sub
    End If
    
    ' Set the selected range
    Set rng = Selection
    
    ' Create a dictionary to store unique values
    Set uniqueValues = CreateObject("Scripting.Dictionary")
    
    ' Loop through each cell in the range and add unique values to the dictionary
    For Each cell In rng
        If Not uniqueValues.Exists(cell.value) Then
            uniqueValues.Add cell.value, Nothing
        End If
    Next cell
    
    ' Create a new worksheet
    Set newSheet = Worksheets.Add
    
    ' Initialize the row counter for the new sheet
    newRow = 1
    
    ' Copy unique values to the new sheet
    For Each Key In uniqueValues.keys
        newSheet.Cells(newRow, 1).value = Key
        newRow = newRow + 1
    Next Key
    
    ' Autofit columns on the new sheet
    newSheet.Columns.AutoFit
    
    ' Notify the user
    MsgBox "Unique values copied to new sheet successfully!", vbInformation
End Sub

 

[Cubist]

Not test, but try:

Sub CopyUniqueVisibleValuesToNewSheet()
    Dim rng As Range
    Dim visibleCells As Range
    Dim uniqueValues As Object
    Dim cell As Range
    Dim newSheet As Worksheet
    Dim newRow As Long
    
    If TypeName(Selection) <> "Range" Then
        MsgBox "No range selected!", vbExclamation
        Exit Sub
    End If
    
    Set rng = Selection
    
    On Error Resume Next
    Set visibleCells = rng.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    
    If visibleCells Is Nothing Then
        MsgBox "No visible cells in the selected range!", vbExclamation
        Exit Sub
    End If
    
    Set rng = visibleCells
    
    Set uniqueValues = CreateObject("Scripting.Dictionary")
    
    For Each cell In rng
        If Not uniqueValues.Exists(cell.Value) Then
            uniqueValues.Add cell.Value, Nothing
        End If
    Next cell
    
    Set newSheet = Worksheets.Add
    
    newRow = 1
    
    For Each Key In uniqueValues.Keys
        newSheet.Cells(newRow, 1).Value = Key
        newRow = newRow + 1
    Next Key
    
    newSheet.Columns.AutoFit
    
    MsgBox "Unique visible values copied to new sheet successfully!", vbInformation
End Sub

 

[jolivanes]

Sub Or_Maybe_So()
Dim i As Long, c As Range
Dim unArr
Dim sh2 As Worksheet
Set sh2 = Worksheets("Sheet2")
    For Each c In Selection
        If c.EntireRow.Hidden = False Then unArr = unArr & "|" & c.Value
    Next c
unArr = Split(Mid(unArr, 2), "|")
    With sh2
        .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = unArr(0)
        For i = 1 To UBound(unArr)
            If WorksheetFunction.CountIf(.Range("A:A"), unArr(i)) = 0 Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Value = unArr(i)     'Cells(lr + 1, 3).Value = frArr(j)
        Next i
    End With
End Sub

 

[nirvehex]

Not test, but try:

Sub CopyUniqueVisibleValuesToNewSheet()
    Dim rng As Range
    Dim visibleCells As Range
    Dim uniqueValues As Object
    Dim cell As Range
    Dim newSheet As Worksheet
    Dim newRow As Long
   
    If TypeName(Selection) <> "Range" Then
        MsgBox "No range selected!", vbExclamation
        Exit Sub
    End If
   
    Set rng = Selection
   
    On Error Resume Next
    Set visibleCells = rng.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
   
    If visibleCells Is Nothing Then
        MsgBox "No visible cells in the selected range!", vbExclamation
        Exit Sub
    End If
   
    Set rng = visibleCells
   
    Set uniqueValues = CreateObject("Scripting.Dictionary")
   
    For Each cell In rng
        If Not uniqueValues.Exists(cell.Value) Then
            uniqueValues.Add cell.Value, Nothing
        End If
    Next cell
   
    Set newSheet = Worksheets.Add
   
    newRow = 1
   
    For Each Key In uniqueValues.Keys
        newSheet.Cells(newRow, 1).Value = Key
        newRow = newRow + 1
    Next Key
   
    newSheet.Columns.AutoFit
   
    MsgBox "Unique visible values copied to new sheet successfully!", vbInformation
End Sub

This worked! Thanks so much!