Select next unique value - excel

Question

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

Answer 1

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.

Answer 2

I managed to work around using this:
Sub TDSFillTest()
Dim BadgeNo As Integer
Dim BlankCount As Integer
Dim LoopCount As Integer
LoopCount = 1
ThisVal = ActiveCell.Value
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
Worksheets("Timesheet").Activate 'Go to Timesheet and count blank cells
BlankCount = Range(("C8"), Cells(Rows.Count, 2).End(xlUp)).Cells.SpecialCells(xlCellTypeBlanks).Count
Worksheets("All Go").Activate 'Starting Point
Range("F3").Copy Worksheets("Timesheet").Range("C8") 'First Value to Timesheet
Worksheets("All Go").Activate ' Return to TDS
Range("F3").Select
Do Until LoopCount > BlankCount
Worksheets("All Go").Activate
Do
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> ActiveCell.Offset(-1, 0).Value Then Exit Do
Loop
ActiveCell.Copy
Worksheets("Timesheet").Activate
ActiveCell.Offset(1, 0).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
LoopCount = LoopCount + 1
Loop
End Sub
I'm going to take yours and run through it in detail so I can learn the more efficient methods. Thanks!