Search code examples
excelvbaloopsfindunique

Select next unique value

I am looking to copy data from a column to a column on another sheet.

Sheet one has a list of ID numbers (starting at F3) next to clock in and out times. There will be anything from 5 - 31 entries of the ID number, before moving to the next employee.

On sheet two is a time sheet with one row per day. The first row of each employee is blank (starting at C8) with the balance of data on that row (name, trade, site etc.) being a reference to this blank cell. There will be anywhere from 29 - 31 rows per employee on sheet two, to allow for all calendar days of the month.

I am trying to search sheet one for the next unique ID, then copy that value to the next available blank cell on sheet two.

The code I have works (sort of) when referencing between sheets and filling in the first value. Selecting the next unique value and then looping till the end of the list is eluding me.

Image of spreadsheets: https://www.dropbox.com/s/vg08uxb9kma2tza/VBA%20Help.jpg?dl=0

Sub TimesheetID()

ThisVal = ActiveCell.Value
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
FinalRow = Cells(Rows.Count, 2).End(xlUp).Row

Worksheets("All Go").Activate

Range("E3").Select
Selection.Copy

Worksheets("Timesheet").Activate

Range("C7").Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
    .Name = "Arial"
    .Size = 8
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = 1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
With Selection.Font
    .Name = "Arial"
    .Size = 11
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = 1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlBottom
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select

Worksheets("All GO").Activate

GoAgain:
    ThisRow = ThisRow + 1
    If ThisRow > Application.Rows.Count Then
        Cells(ThisRow - 1, ThisCol).Select
        Beep
        Exit Sub
    End If
    If Cells(ThisRow, ThisCol).Value = ThisVal Then
        GoTo GoAgain
    Else
        Cells(ThisRow, ThisCol).Select
    End If

ActiveCell.Select
Selection.Copy

Worksheets("Timesheet").Activate

ActiveSheet.Paste
 Application.CutCopyMode = False
With Selection.Font
    .Name = "Arial"
    .Size = 8
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = 1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
With Selection.Font
    .Name = "Arial"
    .Size = 11
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = 1
    .TintAndShade = 0
    .ThemeFont = xlThemeFontNone
End With
With Selection
    .HorizontalAlignment = xlLeft
    .VerticalAlignment = xlBottom
    .WrapText = True
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With 

End Sub
Solution

  • This example uses two dictionaries and the Dictionary.Exists method to create an array of unique values from the range A1:A50.

    Option Explicit

Sub UniqueList()

    Dim UniqueDic As Object

    Dim AllDic As Object 

    Dim rng As Range 

    Dim c As Range 

    Dim UniqueArray() As Variant

    Set UniqueDic = CreateObject("Scripting.Dictionary") 

    Set AllDic = CreateObject("Scripting.Dictionary")

    Set rng = ActiveSheet.Range("$A$1:$A50") 

    For Each c In rng.Cells

        If Not AllDic.Exists(c.Value2)

            UniqueDic.Add c.Value2, c.Row 

            AllDic.Add c.Value2, c.Row

        Else

            If Not UniqueDic.Exists(c.Value2) Then 

                UniqueDic.Remove c.Value2

            End If

        End If

    Next

    UniqueArray() = Array(UniqueDic.Keys)

End Sub

    If a range is traversed and a dictionary, "AllDic", gains a key equal to the cell value when Not AllDic.Exists Cell.Value evaluates to true; then AllDic.Keys will return an array of values unique to "AllDic" but not necessarily unique to the range.

    Using two dictionaries, "AllDic" and "UniqueDic", if they both get the same key when Not AllDic.Exists Cell.Value evaluates to true, but when it is false "UniqueDic" will lose a key if Not UniqueDic.Exists Cell.Value is true; then keys from both dictionaries will return arrays with unique values, however, "UniqueDic" will not have any values that repeat in the range.