Option Explicit
Sub Glechoma_hederacea()
Const insht As String = "Input"
Const ousht As String = "Output"
Dim i As Long, j As Long, k As Long, n As Long
Dim dlmtrL As String, dlmtrS As String, dlmtrT As String
Dim arr, e, rslt, splt
'----------------------------------------------------------------
dlmtrL = vbLf
dlmtrS = ":"
dlmtrT = ";"
'----------------------------------------------------------------
With Worksheets(insht)
arr = .Range("B2:C" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
k = UBound(arr, 1)
'----------------------------------------------------------------
Do While Right$(arr(2, 2), 1) = dlmtrL
arr(2, 2) = Trim$(Left$(arr(2, 2), Len(arr(2, 2)) - 1))
Loop
splt = Split(arr(2, 2), dlmtrL, -1, 0)
n = UBound(splt) + 2
'----------------------------------------------------------------
ReDim rslt(1 To k, 1 To n)
rslt(1, 1) = Trim$(arr(1, 1))
For i = 2 To n
rslt(1, i) = Trim$(Split(splt(i - 2), dlmtrS, -1, 0)(0))
Next
For i = 2 To k
rslt(i, 1) = Trim$(arr(i, 1))
Do While Right$(arr(i, 2), 1) = dlmtrL
arr(i, 2) = Trim$(Left$(arr(i, 2), Len(arr(i, 2)) - 1))
Loop
splt = Split(arr(i, 2), dlmtrL, -1, 0)
For j = 2 To n
e = Trim$(Split(splt(j - 2), dlmtrS, -1, 0)(1))
rslt(i, j) = IIf(IsNumeric(e), Val(e), e)
Next
Next
'----------------------------------------------------------------
With Worksheets(ousht)
.Range("B1").Resize(k, n).Value = rslt
.Select
End With
End Sub
Bookmarks