Sub kolonkiwodnu()
    
       Dim txt$, txt1$, txt2$
' ===========Colomn yellow===========================
    txt$ = Worksheets("1").Range("A1").Value
 
    
    arr = ParseColumnsStringEx(txt)
 
For i = LBound(arr) To UBound(arr): Debug.Print arr(i) & ",";: Next i: Debug.Print
    columnsListE$ = Join(arr)
    Worksheets(1).Cells(2, 3) = columnsListE$
'zapolnenie stolbca A
    Application.ScreenUpdating = False
    With Worksheets(1)
  
    For i = LBound(arr) To UBound(arr)
        ActiveColomn = CInt(arr(i)) 'prieobrazowanie I w integer potomu czto budet osibka w .Cells()
        LastRow = .Cells(Rows.Count, ActiveColomn).End(xlUp).Row
            For ActiveRaw = 2 To LastRow
                If .Cells(ActiveRaw, ActiveColomn) <> "" Then Worksheets(2).Cells(Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = .Cells(ActiveRaw, ActiveColomn)
            Next
    Next
   ' .Range("A:A").RemoveDuplicates Columns:=1
    End With
    Application.ScreenUpdating = True
        
' ===========Colomn green===========================
    txt$ = Worksheets("1").Range("B1").Value
    arr2 = ParseColumnsStringEx(txt)
    
    For i = LBound(arr2) To UBound(arr2): Debug.Print arr(i) & ",";: Next i: Debug.Print
     columnsListD$ = Join(arr2)
     Worksheets(1).Cells(3, 3) = columnsListD$
        Application.ScreenUpdating = False
    'zapolnenie stolbca B
    Application.ScreenUpdating = False
    With Worksheets(1)
    
    For i = LBound(arr2) To UBound(arr2)
        ActiveColomn = CInt(arr2(i)) 'prieobrazowanie I w integer potomu cto budet osibka w .Cells()
        LastRow = .Cells(Rows.Count, ActiveColomn).End(xlUp).Row
            For ActiveRaw = 2 To LastRow
                If .Cells(ActiveRaw, ActiveColomn) <> "" Then Worksheets(2).Cells(Worksheets(2).Cells(Rows.Count, 2).End(xlUp).Row + 1, 2) = .Cells(ActiveRaw, ActiveColomn)
            Next
    Next
   ' .Range("A:A").RemoveDuplicates Columns:=1
    End With
    Application.ScreenUpdating = True

   
 End Sub
Function ParseColumnsStringEx(ByVal txt$, Optional ByRef norm1$, Optional ByRef norm2$) As Variant
    On Error Resume Next
    Const enARR$ = "ABCEHKMOPTX", ruARR$ = "???????????"
    Const cc& = 256
    For i = 1 To Len(enARR$): txt = Replace(txt, Mid(ruARR$, i, 1), Mid(enARR$, i, 1)): Next i
    txt = Replace(txt, " ", ""): txt = Replace(txt, ";", ",")
    txt = Replace(txt, ":", "-"): txt = Replace(txt, ".", ","): txt = UCase(txt)
    For i = 1 To Len(txt)
        If Not Mid(txt, i, 1) Like "[A-Z0-9,-]" Then Mid(txt, i, 1) = ","
    Next i
    While InStr(1, txt, ",,"): txt = Replace(txt, ",,", ","): Wend
    While InStr(1, txt, "--"): txt = Replace(txt, "--", "-"): Wend
    txt = Replace(txt, ",-", ","): txt = Replace(txt, "-,", ",")
    If Left(txt, 1) = "-" Or Left(txt, 1) = "," Then txt = Mid(txt, 2)
    If Right(txt, 1) = "-" Or Right(txt, 1) = "," Then txt = Left(txt, Len(txt) - 1)
    norm1$ = Replace(txt$, ",", ";")
    arr = Split(txt$, ","): Dim n As Long: ReDim tmpArr(0 To 0)
    For i = LBound(arr) To UBound(arr)
        spl = Split(arr(i), "-")
        For j = LBound(spl) To UBound(spl)
            cn& = 0: cn& = ColumnNameToColumnNumber(spl(j)): If cn& Then spl(j) = cn&
            If Not spl(j) Like String(Len(spl(j)), "#") Then spl(j) = ""
        Next j
        If Val(spl(0)) > cc& Then spl(0) = "": spl(UBound(spl)) = ""
        If Val(spl(UBound(spl))) > cc& Then spl(UBound(spl)) = cc&
        If UBound(spl) > 1 Then arr(i) = spl(0) & "-" & spl(UBound(spl)) Else arr(i) = Join(spl, "-")
        If UBound(spl) = 1 Then If spl(0) = spl(1) Then arr(i) = spl(0)
        If UBound(spl) = 1 Then If spl(0) = "" Then arr(i) = spl(1)
    Next i
    norm2$ = Join(arr, ","): norm2$ = Replace(norm2$, ",-", ","): norm2$ = Replace(norm2$, "-,", ",")
    While InStr(1, norm2$, ",,"): norm2$ = Replace(norm2$, ",,", ","): Wend
    If Left(norm2$, 1) = "," Then norm2$ = Mid(norm2$, 2)
    If Right(norm2$, 1) = "," Then norm2$ = Left(norm2$, Len(norm2$) - 1)
 
    For i = LBound(arr) To UBound(arr)
        Select Case True
            Case arr(i) = "", Val(arr(i)) < 0
            Case IsNumeric(arr(i))
                tmpArr(UBound(tmpArr)) = arr(i): ReDim Preserve tmpArr(0 To UBound(tmpArr) + 1)
            Case arr(i) Like "*#-#*"
                spl = Split(arr(i), "-")
                If UBound(spl) = 1 Then
                    If IsNumeric(spl(0)) And IsNumeric(spl(1)) Then
                        If spl(0) <= cc& Then
                            If spl(1) > cc& Then spl(1) = cc&
                            For j = Val(spl(0)) To Val(spl(1)) Step IIf(Val(spl(0)) > Val(spl(1)), -1, 1)
                                tmpArr(UBound(tmpArr)) = j: ReDim Preserve tmpArr(0 To UBound(tmpArr) + 1)
                            Next j
                        End If
                    End If
                End If
        End Select
    Next i
    If UBound(tmpArr) Then
        ReDim Preserve tmpArr(0 To UBound(tmpArr) - 1)
        ParseColumnsStringEx = tmpArr
    End If
End Function
 
Function ColumnNameToColumnNumber(ByVal txt$) As Long
    On Error Resume Next
    ColumnNameToColumnNumber = Split(Application.ConvertFormula(txt$ & "1", xlA1, xlR1C1, True), "C")(1)
End Function