CODEWITHSUNDEEP
excelvba
Andy Moore
Andy Moore

Reputation: 35

VBA - Copy column range values to specific sheet, remove duplicates

I'm attempting to copy a specific range on an active sheet, then add those values to an existing list on a different sheet within the same workbook.

After that is finished, I would like to remove any duplicates that have been added.

Sub CopyUnique()
    Dim s1 As Worksheet, s2 As Worksheet, FirstEmptyRow As Long, expCol As Long
    Set s1 = ActiveSheet
    Set s2 = Sheets("Products")
    Range("A:A").Cells.Name = "types"
    expCol = Range("types").Column
    FirstEmptyRow = Cells(Rows.Count, expCol).End(xlUp).Row + 1
    s1.Range("C4:C33").Copy s2.Range(FirstEmptyRow)
    s2.Range("Products").Column.RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

I am rather new to VBA, and I may have been staring at this for too long, but I am not gaining any ground with the above code.

Any advice is appreciated.

Upvotes: 0

Views: 1538

Answers (2)

DisplayName
DisplayName

Reputation: 13386

You may try this

Sub CopyUnique()
    Dim s1 As Worksheet, FirstEmptyRow As Long, expCol As Long
    Set s1 = ActiveSheet
    With Sheets("Products")
        .Range("A:A").Name = "types"
        expCol = .Range("types").Column
        FirstEmptyRow = .Cells(.Rows.Count, expCol).End(xlUp).Row + 1
        s1.Range("C4:C33").Copy .Cells(FirstEmptyRow, expCol)
        .Range("types").RemoveDuplicates Columns:=1, Header:=xlNo
    End With
End Sub

But from what I can see in your code, you could reduce it to:

Sub CopyUnique()
    Dim s1 As Worksheet
    Set s1 = ActiveSheet
    With Sheets("Products")
        s1.Range("C4:C33").Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
        Intersect(.UsedRange, .Columns(1)).RemoveDuplicates Columns:=1, Header:=xlNo
        .Range("A" & .Cells(.Rows.Count, 1).End(xlUp)).Name = "types"
    End With
End Sub

Upvotes: 2

K.Dᴀᴠɪs
K.Dᴀᴠɪs

Reputation: 10139

You can try out this function I have stowed away in my personal Macro workbook:

Function rngToUniqueArr(ByVal rng As Range) As Variant

    'Reference to [Microsoft Scripting Runtime] Required
    Dim dict As New Scripting.Dictionary, cel As Range
    For Each cel In rng.Cells
        dict(cel.Value) = 1
    Next cel
    rngToUniqueArr = dict.Keys

End Function

Notice: You will need to create a reference to the Microsoft Scripting Runtime Library

Which you would use in conjunction with your new sub:

Sub CopyUnique()

    Dim s1 As Worksheet, s2 As Worksheet
    Set s1 = ThisWorkbook.ActiveSheet
    Set s2 = ThisWorkbook.Worksheets("Products")

    Dim rngToCopy As Range, valArr() As Variant
    Set rngToCopy = s1.UsedRange.Columns("A")
    valArr = rngToUniqueArr(rngToCopy)

    ' A10 start is an example. You may start at any row by changing the below value
    Dim copyToRng As Range
    Set copyToRng = s2.Range("A10:A" & 10 + UBound(valArr))

    With Application.WorksheetFunction
        copyToRng = .Transpose(valArr)
    End With

End Sub

Essentially, with this dictionary, you are creating unique "keys" and outputting the result of the dictionary to an array.

The reason you need to transpose this array is that it's one dimensional. A 1-D array in excel is a horizontal line, so we do this to make it vertical. You can also create a 2-D array to avoid using Transpose, but it's generally an easier task to do it this way.

Upvotes: 0

Related Questions