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

CodePudding user response：

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