CODEWITHSUNDEEP
excelvba
Alex Shangin
Alex Shangin

Reputation: 99

copying unique filtered column values VBA

I have a table that have logins in one column and phone numbers in another. I need to copy all phone numbers of each login and paste them to another sheet. But i need only unique phone numbers as one login may contain many records with the same phone number. What i have tried and what failed

For Each rCell In Sheets("PotentialFraud").Range("B1:B" & IndexValueLastRow("B:B"))
    .Range("A2").AutoFilter _
    field:=12, _
    Criteria1:=rCell.Value2
    LastRow = .Cells(1, 1).SpecialCells(xlCellTypeVisible).End(xlDown).Row
    .Range("P1:P" & LastRow).Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
    Worksheets("PotentialFraud").Range(rCell.Offset(0, 2).Address).PasteSpecial Transpose:=True
Next rCell

This Method does not give me an option to copy only unique values. Another option I found was to use Advanced Filter

   .Range("P2:P" & LastRow).Offset(1, 0).SpecialCells(xlCellTypeVisible).AdvancedFilter _
        Action:=xlFilterCopy, _
        CopyToRange:=Worksheets("PotentialFraud").Range("A:A"), _
        Unique:=True

However, this lead to error 1004 saying either This command requires at least two rows of source data... even though there are 2500 rows visible. Either Application-defined or object-defined error if i change the range to

    .Range("P:P" & LastRow).Offset(1, 0).SpecialCells(xlCellTypeVisible).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Worksheets("PotentialFraud").Range("A:A"), _
Unique:=True

("P2:P") to ("P:P")

Upvotes: 0

Views: 1393

Answers (2)

Zev Spitz
Zev Spitz

Reputation: 15307

Assuming you want unique login-phone pairs (and not just unique phones), you could issue an SQL statement against the worksheet, and use CopyFromRecordset to paste it into a new worksheet.

Add a reference to Microsoft ActiveX Data Objects 6.1 Library (via Tools -> References...). There may be versions other than 6.1; choose the highest.

Assuming the logins are in column A and the phone numbers are in column P, and the source data's sheet name is RawData, you could then write the following:

Dim connectionString As String
connectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=""" & ActiveWorkbook.FullName & """;" & _
    "Extended Properties=""Excel 12.0;HDR=No"""

Dim sql As String
sql = _
    "SELECT DISTINCT F1, F16 " & _
    "FROM [RawData$A:P]"

Dim rs As New ADODB.Recordset
rs.Open sql, connectionString

Worksheets("PotentialFraud").Range("A1").CopyFromRecordset rs

Notes:

  • If you want to exclude headers from the data, set HDR=Yes instead of HDR=No in the connection string. In that case, the field names will not be autodefined (e.g. F1, F2 etc.) but will be the names defined in the first row; the SQL should be adjusted accordingly (e.g. SELECT Login, Phone ... instead of SELECT F1, F16 ...)
  • The code which reads in the data (until the last line, which actually pastes the data into the worksheet) requires only the ActiveX Data Objects object library, and is thus independent of any given host or host object model. You only need the path to the Excel file, instead of ActiveWorkbook.FullName.

Alternatively, you could use a Dictionary. (Add a reference to Microsoft Scripting Runtime.)

Choose some character that won't appear in either the login or the phone, and use the concatenated login+character+phone as the key of the dictionary. (In the code below, I am using ~.)

Dim arr As Variant
arr = ActiveSheet.UsedRange.Value

Dim separator As String
separator = "~"

Dim dict As New Dictionary
Dim i As Integer
For i = 1 To UBound(arr)
    dict(arr(i, 1) & separator & arr(i, 2)) = 1 'dummy value
Next

Then, you can iterate over the keys, split the key on the character, and write the parts into the appropriate destination cells.

arr = dict.Keys
For i = 0 To UBound(arr)
    Dim key As String
    key = arr(i)

    With Worksheets("PotentialFraud")
        .Range(.Cells(i + 1, 1), .Cells(i + 1, 2)).Value = Split(key, separator)
    End With
Next

Even better than iterating over the keys, you could write the returned array from the Keys method into the Value property of an appropriately sized Range, and then call TextToColumns on the Range.

'Fill dictionary, as above

arr = dict.Keys
Dim rng As Range
Set rng = Worksheets("PotentialFraud").Range("A1:A" & (UBound(arr) + 1))
rng.Value = dict.Keys
rng.TextToColumns Other:=True, otherchar:=separator

References

ActiveX Data Objects

Excel

Scripting Runtime

VBA

Upvotes: 1

Franksta
Franksta

Reputation: 139

Why cant you just use the onboard remove duplicates function in excel? https://support.office.com/en-us/article/filter-for-unique-values-or-remove-duplicate-values-ccf664b0-81d6-449b-bbe1-8daaec1e83c2

Or in VBA:

ActiveSheet.Range("A1:C100").RemoveDuplicates Columns:=Array(1,2), Header:=xlYes

Upvotes: 1

Related Questions