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
|
