VBA Code Loop Copy Paste Transpose

Jeanpierre

New Member
Joined
Jul 13, 2021
Messages
10
Office Version
  1. 365
Platform
  1. Windows
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:

VBA Code:
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.

VBA Code:
   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.
VBA Code:
 

Attachments

  • image2.jpg
    image2.jpg
    97 KB · Views: 23
  • image1.jpg
    image1.jpg
    110 KB · Views: 26

Jeanpierre

New Member
Joined
Jul 13, 2021
Messages
10
Office Version
  1. 365
Platform
  1. Windows
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.
 

Attachments

  • image1.jpg
    image1.jpg
    110 KB · Views: 5
  • image2.jpg
    image2.jpg
    97 KB · Views: 4

Excel Facts

What did Pito Salas invent?
Pito Salas, working for Lotus, popularized what would become to be pivot tables. It was released as Lotus Improv in 1989.

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
51,220
Office Version
  1. 365
Platform
  1. Windows
Is this what you mean?

VBA Code:
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

New Member
Joined
Jul 13, 2021
Messages
10
Office Version
  1. 365
Platform
  1. Windows
Good day Peter, you are an absolute genius. Thank you yes it does work.

Is this what you mean?

VBA Code:
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
 

Forum statistics

Threads
1,144,617
Messages
5,725,326
Members
422,615
Latest member
Mareza

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top