How to return a unique value from a range of Excel VBA values

Question

I have a table with three fields (ID, Price, Date) in excel. It has four entries:

ID Price  Date
1  $400   1/1/2010
2  $500   1/2/2010
3  $200   1/1/2010
4  $899   1/2/2010

I would like to take each date value and place it in a cell A2, A3, A4.... but I want to use only unique date and do not take a date that has already been stored in the previous cell. For example, the date 1/1/2010should be stored in a cell A2and 1/2/2010should be stored in a cell A3. When it comes to the third record, which 1/1/2010, she should ignore it, because a similar date has already been found earlier and so on. Thank you for your help!

Answer 1

VBA, . , , . .

Option Explicit

Sub Main()
    Dim wsSource As Worksheet
    Dim wsDestination As Worksheet
    Dim uniqueCol As String
    Set wsSource = Worksheets("Sheet1")
    Set wsDestination = Worksheets("Sheet2")
    uniqueCol = "C"
    CopyFirstUniqueValuesToOtherWorksheet _
        wsSource, _
        wsDestination, _
        uniqueCol
End Sub

Sub CopyFirstUniqueValuesToOtherWorksheet( _
    sourceSheet As Worksheet, _
    destinationSheet As Worksheet, _
    uniqueCol As String)

    Dim iRow As Long
    Dim iHeaderRow As Long
    Dim rngUnique As Range
    iHeaderRow = 1
    iRow = iHeaderRow + 1

    'Clear contents of destination sheet '
    ClearDestinationSheet sourceSheet, destinationSheet

    'Copy Header Row '
    CopyRow sourceSheet, destinationSheet, iHeaderRow

    'Loop through source sheet and copy unique values '
    Do While Not IsEmpty(sourceSheet.Range("A" & iRow).value)
        Set rngUnique = sourceSheet.Range(uniqueCol & iRow)
        If Not ValueExistsInColumn(destinationSheet, uniqueCol, _
          CStr(rngUnique.value)) Then
            CopyRow sourceSheet, destinationSheet, iRow
        End If
        iRow = iRow + 1
    Loop


End Sub

Sub CopyRow(sourceSheet As Worksheet, _
    destinationSheet As Worksheet, _
    sourceRow As Long)

    Dim iDestRow As Long
    sourceSheet.Select
    sourceSheet.Rows(sourceRow & ":" & sourceRow).Select
    Selection.Copy
    iDestRow = 1
    Do While Not IsEmpty(destinationSheet.Range("A" & iDestRow).value)
        iDestRow = iDestRow + 1
    Loop
    destinationSheet.Select
    destinationSheet.Rows(iDestRow & ":" & iDestRow).Select
    ActiveSheet.Paste
    sourceSheet.Select
End Sub

Sub ClearDestinationSheet(sourceSheet As Worksheet, _
    destinationSheet As Worksheet)

    destinationSheet.Select
    Cells.Select
    Selection.ClearContents
    sourceSheet.Select
End Sub

Function ValueExistsInColumn(sheet As Worksheet, _
    col As String, _
    value As String) As Boolean

    Dim rng As Range
    Dim i As Long
    i = 2

    Do While Not IsEmpty(sheet.Range(col & i).value)
        Set rng = sheet.Range(col & i)
        If CStr(rng.value) = value Then
            ValueExistsInColumn = True
            Exit Function
        End If
        i = i + 1
    Loop

    ValueExistsInColumn = False
End Function