Sub sds()
Dim arr, i As Long, lr As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("A1:A" & lr)
For i = LBound(arr) To UBound(arr)
    If Not arr(i, 1) = Empty Then
        If x = Empty Then
            x = arr(i, 1)
        Else
            x = x & "; " & arr(i, 1)
        End If
    End If
Next i
Cells(1, 3) = x
End Sub