VBA Code Loop Copy Paste Transpose

[Jeanpierre]

Good day, I am newish to Visual Basic, apologies if this has been posted but i have searched through most of the forums and could not find this specific one. Basically what I need to do is a data sort from a file that information is not aligned properly.

It comes with information in Cell A, Cell B, Cell C, then Cell C2 (this cell needs to be text to column, comma sorted and then transposed), which I need to put in Cell A Cell B and Cell C.
The first part is easy, create a new data page, change data into columns (not sure if can avoid this step) as below:

Columns("C:C").Select
    Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2)), TrailingMinusNumbers:=True
    Sheets.Add After:=ActiveSheet
    Sheets("Sheet1").Select
    Sheets("Sheet1").Name = "Data Output"
    Sheets("Demo").Select
    Range("C1").Select
    Sheets("Data Output").Select
    ActiveCell.FormulaR1C1 = "Cell A"
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Cell B"
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Cell C"
    Range("A2").Select
    Sheets("Demo").Select
    Range("B1").Select
    Selection.Copy
    Sheets("Data Output").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False

Now i need to copy and paste the data from the demo sheet neatly into data output sheet but the cells in C2 need to be copied and transposed on data output sheet and then this code needs to be looped for every repeat of cell C1 & Cell C2 till no data in column C.

   Range("B2").Select
    Sheets("Demo").Select
    Range("C1").Select
    Selection.Copy
    Sheets("Data Output").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("C2").Select
    Sheets("Demo").Select
    Range("C2:V2").Select
    Selection.Copy
    Sheets("Data Output").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Range("B2").Select
    Application.CutCopyMode = False
    Selection.Copy
    Range("B3:B5").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select
  
  Application.CutCopyMode = False

Images attached shows before and after, so I just need to loop it, and the code above might be primitive to the professionals, done with recording. Thank you.

 

[Jeanpierre]

I need to borrow your brain one of these days.

One last thing, sorry was my fault, the output file, 'cell a' doesn't copy down like 'cell b'. on your code it does pull the new number every 16 cells or so how would i get that to copy like Cell B.

 

[Peter_SSs]

Is this what you mean?

Sub Data_Output()
  Dim a As Variant, b As Variant, itm As Variant
  Dim i As Long, k As Long
  Dim CellA As String
  
  a = Sheets("Demo").Range("B1", Sheets("Demo").Range("C" & Rows.Count).End(xlUp)).Value2
  ReDim b(1 To Rows.Count, 1 To 3)
  For i = 1 To UBound(a) - 1 Step 2
    If Len(a(i, 1)) > 0 Then CellA = a(i, 1)
    For Each itm In Split(a(i + 1, 2), ",")
      k = k + 1
      b(k, 1) = CellA: b(k, 2) = a(i, 2): b(k, 3) = itm
    Next itm
  Next i
  Sheets.Add(After:=Sheets("Demo")).Name = "Data Output"
  With Sheets("Data Output")
    .Range("A1:C1").Value = Array("Cell A", "Cell B", "Cell C")
    With .Range("A2:C2").Resize(k)
      .NumberFormat = "@"
      .Value = b
      .Columns.AutoFit
    End With
  End With
End Sub

 

[Jeanpierre]

Good day Peter, you are an absolute genius. Thank you yes it does work.

Is this what you mean?

Sub Data_Output()
  Dim a As Variant, b As Variant, itm As Variant
  Dim i As Long, k As Long
  Dim CellA As String
 
  a = Sheets("Demo").Range("B1", Sheets("Demo").Range("C" & Rows.Count).End(xlUp)).Value2
  ReDim b(1 To Rows.Count, 1 To 3)
  For i = 1 To UBound(a) - 1 Step 2
    If Len(a(i, 1)) > 0 Then CellA = a(i, 1)
    For Each itm In Split(a(i + 1, 2), ",")
      k = k + 1
      b(k, 1) = CellA: b(k, 2) = a(i, 2): b(k, 3) = itm
    Next itm
  Next i
  Sheets.Add(After:=Sheets("Demo")).Name = "Data Output"
  With Sheets("Data Output")
    .Range("A1:C1").Value = Array("Cell A", "Cell B", "Cell C")
    With .Range("A2:C2").Resize(k)
      .NumberFormat = "@"
      .Value = b
      .Columns.AutoFit
    End With
  End With
End Sub

 

[Peter_SSs]

Cheers. No problem.