VBA get unique value from range and result input every second row - excel

Question

I have two macros that I would like to combine but somehow its not going well...
I want a macro that will get only unique values from a range and input them into another sheet every second row starting from row no 3
Could anyone tell me how should I combine those two macros?
I have tried to change .Font.Size = 20 with Application.Transpose(objDict.keys) but it didn't work.
Sub UniqueValue()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range("F1:F" & objDict.Count) = Application.Transpose(objDict.keys)
End Sub
Sub EverySecond()
Dim EndRow As Long
EndRow = Range("A" & Rows.Count).End(xlUp).Row
For ColNum = 5 To EndRow Step 2
Range(Cells(ColNum, 2), Cells(ColNum, 2)).Font.Size = 20
Next ColNum
End Sub

Answer 1

Copy Unique Values to Every Other Row
Option Explicit
Sub UniqueEveryOther()
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "A2"
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A2"
Dim wb As Workbook: Set wb = ThisWorkbook
' Reference the source range.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range
Dim srCount As Long
With sws.Range(sFirstCellAddress)
Dim lCell As Range: Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub
srCount = lCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
' Write the values from the source range to an array.
1
Dim Data As Variant
If srCount = 1 Then ' one cell
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = srg.Value
Else ' multiple cells
Data = srg.Value
End If
' Write the unqiue values from the array to a dictionary.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Key As Variant
Dim r As Long
For r = 1 To srCount
Key = Data(r, 1)
If Not IsError(Key) Then
If Len(Key) > 0 Then
dict(Key) = Empty
End If
End If
Next r
If dict.Count = 0 Then Exit Sub
' Write the unqiue values from the dictionary to the array.
ReDim Data(1 To 2 * dict.Count - 1, 1 To 1)
r = -1
For Each Key In dict.Keys
r = r + 2
Data(r, 1) = Key
Next Key
' Write the unique values from the array to the destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dFirstCellAddress)
.Resize(r).Value = Data
.Resize(dws.Rows.Count - .Row - r + 1).Offset(r).Clear
'.EntireColumn = AutoFit
End With
'wb.Save
MsgBox "Uniques populated.", vbInformation
End Sub