Each row in a column and copy/paste result in first free cell in another column

Question

I need to take a list of strings in a sheet and transform them into a list in a new sheet, the strings in Sheet 1 look like:

B87YTDF,ENG,22;B54TRDX,ITA,23
B99REDT,FRA,25;B46TEST,GER,29;B94FRDE,GBT,21

and what I need to obtain in Sheet 2 is:

B87YTDF   ENG   22
B54TRDX   ITA   23
B99REDT   FRA   25
B46TEST   GER   29
B94FRDE   GBT   21

so what I need to do is, for each string (all in the same column):

• copy string from Sheet 1 and paste in the first row of Sheet 2
• in Sheet 2 perform a txt to column separating by ;
• copy the full row, paste it one row below it and transpose
• txt to column separating by ,
• clear the first row that still contains the full string

and repeat this for all non-empty rows in Sheet 1, copying and pasting the string each time in the first free row of Sheet 2.

At this point I am stuck with this, but have no idea of how to loop this for each row in Sheet 1 and have it done in each first free row in Sheet 2.

Rows("1:1").Select

Selection.Copy

Sheets("Sheet5").Select

ActiveSheet.Paste

Application.CutCopyMode = False

Range("A1").Select

Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
    TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
    Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
    :=";", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, _
    1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10, 1), Array(11, 1), Array(12 _
    , 1)), TrailingMinusNumbers:=True

Rows("1:1").Select

Selection.Copy

Range("A2").Select

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=True

Rows("1:1").Select

Application.CutCopyMode = False

Selection.Delete Shift:=xlUp

Thanks for any help!

Answer 1

a no-loop code:

Option Explicit

Sub main()
    Dim vals As Variant

    With Worksheets("Sheet1")
        vals = Split(Join(Application.Transpose(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Value), ";"), ";")
    End With
    With Worksheets("Sheet2").Range("A1").Resize(UBound(vals))
        .Value = Application.Transpose(vals)
        .TextToColumns comma:=True
    End With
End Sub

Answer 2

Below code assumes that you store those trings in column A of Sheet1 and it pastes parsed values in Sheet2 starting with A1 cell.

Try this code:

Sub CopyStrings()
Dim i As Long, ws1 As Worksheet, ws2 As Worksheet, currRow As Long, lastRow As Long, rowsToPaste() As String, rowToPaste() As String, j As Long, k As Long
currRow = 1
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
'here you determine how many rows there are in Sheet1 to copy and parse
lastRow = ws1.Cells(ws1.rows.Count, 1).End(xlUp).Row

For i = 1 To lastRow
    'split current string into rows
    rowsToPaste = Split(Cells(i, 1).Value, ";")
    For j = LBound(rowsToPaste) To UBound(rowsToPaste)
        'split current row and iterate through values and paste then in Sheet2
        rowToPaste = Split(rowsToPaste(j), ",")
        For k = LBound(rowToPaste) To UBound(rowToPaste)
            ws2.Cells(currRow, k + 1).Value = rowToPaste(k)
        Next
        currRow = currRow + 1
    Next
Next
End Sub

Answer 3

Sub test()

Dim S 
Dim vS, v, vR(),mys,Myv
Dim n as Long, i as Long


S = Sheet1.range ("a1").currentregion
'vS = Split(S,Char(10))

For each v in S
   Myv = Split (v,";")
   For each mys in Myv
      n= n+1
      Redim preserve vR (1 to 3,1 to n)
      For i= 0 to 2
        vR (i+1,n) = Split (mys,",")(i)
      Next i
    Next mys
Next v

Sheet2.range ("a1").resize (n,3)= application.Transpose (vR)

End sub