rResultCell.Value = "'" & CStr(rLine)

Sub Extract()
    Set rVals = Range("A1:A1048576")
    Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
    avVals = rVals.Value
    Excel.Range("G2").NumberFormat = "@"
    Set rResultCell = Range("G2")
    ReDim avArr(1 To Rows.Count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each x In avVals
            If Len(CStr(x)) Then
                .Add x, CStr(x)
                If Err = 0 Then
                    li = li + 1
                    avArr(li, 1) = x
                    rLine = rLine & x & ","
                   
                Else
                    Err.Clear
                End If
            End If
        Next
    End With
    rLine = Left(rLine, Len(rLine) - Len(","))
    If li Then rResultCell.Value = CStr(rLine)
    Excel.Range("G2").NumberFormat = "General"
End Sub

Option Explicit
'---------------------------------------------------------------------------------------
' Procedure : СцепитьМного
'             http://www.excel-vba.ru
' Purpose   : Функция сцепляет все указанные ячейки в одну с указанным разделителем.
' Аргументы функции:
' Диапазон    — диапазон ячеек, значения которых необходимо объединить в строку.
' Разделитель — необязательный аргумент.
'               Один или несколько символов, которые будут вставлены между каждым словом.
'               По умолчанию пробел.
' БезПовторов — необязательный аргумент.
'               Если указан как ИСТИНА или 1 — в результирующей строке будут значения без дубликатов.
'               Для английской локализации данный параметр указывается как TRUE и FALSE соответственно.
'---------------------------------------------------------------------------------------
Function СцепитьМного(Диапазон As Range, Optional Разделитель As String = " ", Optional БезПовторов As Boolean = False)
    Dim avData, lr As Long, lc As Long, sRes As String
    avData = Диапазон.Value
    If Not IsArray(avData) Then
        СцепитьМного = avData
        Exit Function
    End If
 
    For lc = 1 To UBound(avData, 2)
        For lr = 1 To UBound(avData, 1)
            If Len(avData(lr, lc)) Then
                sRes = sRes & Разделитель & avData(lr, lc)
            End If
        Next lr
    Next lc
    If Len(sRes) Then
        sRes = Mid(sRes, Len(Разделитель) + 1)
    End If
    
    If БезПовторов Then
        Dim oDict As Object, sTmpStr
        Set oDict = CreateObject("Scripting.Dictionary")
        sTmpStr = Split(sRes, Разделитель)
        On Error Resume Next
        For lr = LBound(sTmpStr) To UBound(sTmpStr)
            oDict.Add sTmpStr(lr), sTmpStr(lr)
        Next lr
        sRes = ""
        sTmpStr = oDict.keys
        For lr = LBound(sTmpStr) To UBound(sTmpStr)
            sRes = sRes & IIf(sRes <> "", Разделитель, "") & sTmpStr(lr)
        Next lr
    End If
    СцепитьМного = sRes
End Function

Sub Extract()
    Set rVals = Range("A1:A1048576")
    Set rVals = Intersect(rVals, rVals.Parent.UsedRange)
    avVals = rVals.Value
    Set rResultCell = Range("G2")
    ReDim avArr(1 To Rows.Count, 1 To 1)
    With New Collection
        On Error Resume Next
        For Each x In avVals
            If Len(CStr(x)) Then
                .Add x, CStr(x)
                If Err = 0 Then
                    li = li + 1
                    avArr(li, 1) = x
                    rLine = rLine & x & ","
                Else
                    Err.Clear
                End If
            End If
        Next
    End With
    rLine = Left(rLine, Len(rLine) - Len(","))
    If li Then rResultCell.Value = CStr(rLine)
End Sub