Sub MozhetBitTak()
Dim MyArr
Dim tmpArr() As Integer
Dim MyString As String
Dim i As Byte, j As Byte, Counter As Byte

MyArr = Range("K6:K9") ' здесь указывать диапазон
ReDim MyArrT( 1  To UBound(MyArr,  1 ) +  1 ,  1  To  3 )

For i =  1  To UBound(MyArr,  1 )
    Counter = Len(MyArr(i,  1 )) - Len(Replace(MyArr(i,  1 ), ",", ""))
    Select Case Counter
    Case Is =  0 
    Cells(i,  1 ).Value = "x:=" & CStr(MyArr(i,  1 )) & ".y"
    Case Is =  1 
    Call getEl(MyArr(i,  1 ), tmpArr(),  2 )
    Cells(i,  1 ).Value = "x:=" & CStr(tmpArr( 1 )) & ".y"
    Cells(i,  2 ).Value = "x:=" & CStr(tmpArr( 2 )) & ".y"
    Case Is >=  2 
    Call getEl(MyArr(i,  1 ), tmpArr(),  3 )
    Cells(i,  1 ).Value = "x:=" & CStr(tmpArr( 1 )) & ".y"
    Cells(i,  2 ).Value = "x:=" & CStr(tmpArr( 2 )) & ".y"
    Cells(i,  3 ).Value = "x:=" & CStr(tmpArr( 3 )) & ".y"
    End Select
Next i

End Sub

Sub getEl(ByVal setElement As String, arr() As Integer, i As Byte)
Dim x As Byte, j As Byte

    For i =  1  To i
        x = x +  1 
        ReDim Preserve arr( 1  To x)
        arr(x) = CInt(Mid(setElement,  1 , InStr(setElement, ",") -  1 ))
        setElement = Mid(setElement, InStr(setElement, ",") +  1 )
        If Len(setElement) - Len(Replace(setElement, ",", "")) =  0  Then
        ReDim Preserve arr( 1  To x +  1 )
        arr(x +  1 ) = setElement
        Exit For
        End If
    Next i
        
End Sub

ReDim MyArrT( 1  To UBound(MyArr,  1 ) +  1 ,  1  To  3 )

Application.Intersect(Worksheets( 1 ).Range("A:A"), Worksheets( 1 ).UsedRange)

Intersect(Worksheets( 1 ).Range("A:A"), Worksheets( 1 ).UsedRange)

For Each cc In Range("здесь диапазон")