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

问题

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

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 value of the date and place it in a cell A2,A3,A4.... however, I want to take only unique dates and do not take any date that was already stored in a previous cell. For example, date 1/1/2010 should be stored in cell A2 and 1/2/2010 should be stored in cell A3. When it comes to the third record which is 1/1/2010 it should ignore it because a similar date was already found previously and so on. Thanks for your help!

回答1:

Here's some VBA code you can use to loop through the first sheet and copy only the first unique row to the second sheet. Your question asked for just the value to be copied, but this code copies the entire row. You could easily remove the unnecessary columns or modify the code.

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

来源：https://stackoverflow.com/questions/3589744/how-to-return-unique-value-from-a-range-of-values-excel-vba

标签

vba

excel-vba

excel