Compare cells of an array to return only the unique values

[goodm009]

Hi guys, I have an array of unknown size (at least 100x 85) , filled with alphanumeric characters and blank cells - basically around 100 lists of vaying lengths. I need to have a way to remove the duplicate cells from across all the lists, leaving only the unique values. And also get rid of the blank cells intermixed - optional. My thought process was to use nested loops to compare the A1 against every cell in array and delete if equal and move on if different, then start back at A2 and proceed on and on. This seems like the simplest solution to me, but I am not well versed in Excel, so I'm having a little difficulty. Here's my code so far, it compiles but does nothing lol

Option Explicit
Sub test()
Dim varSheetA As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Dim iRows As Long
Dim iCols As Long
Dim iCole As Long
' Dim iRowe As Long
' Dim iRowes As Long
' Dim iColes As Long


'Range("A1:DD100").SpecialCells(xlCellTypeBlanks) = "Blank" 'Delete blanks -> sort by by "Blank and delete

strRangeToCheck = "A1:DD100"

varSheetA = Worksheets("Sheet1").Range(strRangeToCheck)

For iRows = LBound(varSheetA, 1) To UBound(varSheetA, 1)
' iRowes = iRows + 1

For iCols = LBound(varSheetA, 2) To UBound(varSheetA, 2)
' iCole = iCols + 1

For iRow = LBound(varSheetA, 1) To UBound(varSheetA, 1)
' iRowe = iRow + 1

For iCol = LBound(varSheetA, 2) To UBound(varSheetA, 2)
iCole = iCol + 1

If iCole < 100 Then

If varSheetA(iRows, iCols) = varSheetA(iRow, iCole) Then ' Cells are identical.
varSheetA(iRow, iCole) = " "
Else ' Cells are different.

End If
End If

Next iCol
Next iRow
Next iCols
Next iRows

End Sub

[xladept]

Hi Goodm,

Try this:

Sub Goodm(): Dim A, r As Long, c As Long
Dim p As Long, q As Long
A = Range("A1:DD100")
For r = 1 To 99: For c = 1 To 107
For p = r + 1 To 100: For q = c + 1 To 108
If A(r, c) <> "" Then
If A(p, q) = A(r, c) Or A(p, q) = " " Then
A(p, q) = ""
End If: End If
Next q: Next p: Next c: Next r
Range("A1:DD100") = A
End Sub

BTW - You need to put code tags around your code (just highlight the code and click the #)

[goodm009]

this is VERY close!. it misses quite a few repeats tho.

[goodm009]

this is VERY close!. it misses quite a few repeats tho.

Hi Goodm,

Try this:

Sub Goodm(): Dim A, r As Long, c As Long
Dim p As Long, q As Long
A = Range("A1:DD100")
For r = 1 To 99: For c = 1 To 107
For p = r + 1 To 100: For q = c + 1 To 108
If A(r, c) <> "" Then
If A(p, q) = A(r, c) Or A(p, q) = " " Then
A(p, q) = ""
End If: End If
Next q: Next p: Next c: Next r
Range("A1:DD100") = A
End Sub

BTW - You need to put code tags around your code (just highlight the code and click the #)

[cytop]

Also: http://www.ozgrid.com/forum/showthread.php?t=181854

[xladept]

See if the Trim and case catches the rest:

Sub Goodm(): Dim A, r As Long, c As Long
Dim p As Long, q As Long
A = Range("A1:DD100")
For r = 1 To 99: For c = 1 To 107
For p = r + 1 To 100: For q = c + 1 To 108
If A(r, c) <> "" Then
If Trim(LCase(A(p, q))) = Trim(LCase(A(r, c))) Or A(p, q) = " " Then
A(p, q) = ""
End If: End If
Next q: Next p: Next c: Next r
Range("A1:DD100") = A
End Sub

[goodm009]

thanks!!! it still doesnt get rid of all the duplicates but it definitely better than where i was going. I'm pretty sure i can make this work for my needs. thanks alot again!!

See if the Trim and case catches the rest:

Sub Goodm(): Dim A, r As Long, c As Long
Dim p As Long, q As Long
A = Range("A1:DD100")
For r = 1 To 99: For c = 1 To 107
For p = r + 1 To 100: For q = c + 1 To 108
If A(r, c) <> "" Then
If Trim(LCase(A(p, q))) = Trim(LCase(A(r, c))) Or A(p, q) = " " Then
A(p, q) = ""
End If: End If
Next q: Next p: Next c: Next r
Range("A1:DD100") = A
End Sub

[xladept]

Hi Goodm,

I actually thought about this in the interim and here's what I've come up with - see if it's good

Sub Goodm(): Dim A, r As Long, c As Long
                Dim p As Long, q As Long
                    A = Range("A1:DD100")
    For r = 1 To 99: For c = 1 To 107
    If A(r, c) = "" Then GoTo GetNext
    
        For q = c + 1 To 108
If Trim(LCase(A(r, c))) = Trim(LCase(A(r, q))) _
Or A(r, q) = " " Then A(r, q) = ""
        Next q

        For p = r + 1 To 100
If Trim(LCase(A(r, c))) = Trim(LCase(A(p, c))) _
Or A(p, c) = " " Then A(p, c) = ""
        Next p

GetNext: Next c: Next r

Range("A1:DD100") = A
End Sub

[goodm009]

that got it. awesome! thanks!

Hi Goodm,

I actually thought about this in the interim and here's what I've come up with - see if it's good

Sub Goodm(): Dim A, r As Long, c As Long
                Dim p As Long, q As Long
                    A = Range("A1:DD100")
    For r = 1 To 99: For c = 1 To 107
    If A(r, c) = "" Then GoTo GetNext
    
        For q = c + 1 To 108
If Trim(LCase(A(r, c))) = Trim(LCase(A(r, q))) _
Or A(r, q) = " " Then A(r, q) = ""
        Next q

        For p = r + 1 To 100
If Trim(LCase(A(r, c))) = Trim(LCase(A(p, c))) _
Or A(p, c) = " " Then A(p, c) = ""
        Next p

GetNext: Next c: Next r

Range("A1:DD100") = A
End Sub

[Kalithro]

How about something like this. Adust code as needed for range required. This loops though range and stores all cells values. Then places values in Sheet2. Then uses Advanced Filter to get only uniques. Macro is setup to use "Sheet1" and "Sheet2".

Sub GetUnique()

Dim TnFv(1 To 10000000) As String, p As Long
Dim remME As Long
Dim x As Long
Dim y As Long



ThisWorkbook.Sheets("Sheet2").Columns("A:B").Clear

For x = 1 To 100
    For y = 1 To 108
        p = p + 1
        TnFv(p) = ThisWorkbook.Sheets("Sheet1").Cells(x, y).Value
    Next y
Next x

remME = p

For p = 1 To remME
    ThisWorkbook.Sheets("Sheet2").Cells(p, 1).Value = TnFv(p)
Next p

Application.CutCopyMode = False
Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Columns( _
        "B:B"), Unique:=True

End Sub

[xladept]

You're welcome - I'm glad that all that gray matter matters!