VBA Code Loop Copy Paste Transpose

J

Jeanpierre

New Member
Joined
Jul 13, 2021
Messages
11
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: 63
  • image1.jpg
    image1.jpg
    110 KB · Views: 66
Sort by date Sort by votes
Anyways, the following is the condensed code from Post #1:

VBA Code: 
    ActiveSheet.Range("C:C").TextToColumns Range("C1"), xlDelimited, _
        xlDoubleQuote, , True, , True, , , _
        FieldInfo:=Array(Array(1, xlTextFormat), Array(2, xlTextFormat), Array(3, xlTextFormat), Array(4, xlTextFormat), Array(5, xlTextFormat)), _
        TrailingMinusNumbers:=True
'
    Sheets.Add(After:=ActiveSheet).Name = "Data Output"
'
    Sheets("Data Output").Range("A1").FormulaR1C1 = "Cell A"            ' Write "Cell A" to cell A1 on Sheet 'Data Output'
    Sheets("Data Output").Range("B1").FormulaR1C1 = "Cell B"            ' Write "Cell B" to cell B1 on Sheet 'Data Output'
    Sheets("Data Output").Range("C1").FormulaR1C1 = "Cell C"            ' Write "Cell C" to cell C1 on Sheet 'Data Output'
'
    Sheets("Demo").Range("B1").Copy Sheets("Data Output").Range("A2")   ' Copy Range("B1") from the 'Demo' sheet to Range("A2") on sheet 'Data Output"
    Sheets("Demo").Range("C1").Copy Sheets("Data Output").Range("B2")   ' Copy Range("C1") from the 'Demo' sheet to Range("B2") on sheet 'Data Output"
'
    Sheets("Demo").Range("C2:V2").Copy                                  ' Copy/Transpose data from 'Demo' sheet to 'Data Output' sheet
    Sheets("Data Output").Range("C2").PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
'
    Sheets("Data Output").Range("B2").Copy Sheets("Data Output").Range("B3:B5")             ' Copy value from 'Data Output' B2 to B3:B5
    Sheets("Data Output").Range("A1").Select
 
Upvote 0

Excel Facts

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).
Good day, apologies for delay, had riots this week in SA. Anyway. Yes that is the way i need it.
 
Upvote 0
So
johnnyL said:
Since there is still confusion of what the sample output would look like, Is the following what the goal is:

Book1
ABC
1Cell ACell BCell C
2224457783224457865050004454
32244578655447778866
4224457865544478993
5224457865555552247
6224457865050004454
72244578655447778866
8224457865544478993
9224457865555552247
10224457865050004454
112244578655447778866
12224457865544478993
13224457865555552247
14224457865050004454
152244578655447778866
16224457865544478993
17224457865555552247
18224457784224457875050004455
19224457875050004455
20224457875050004455
21224457875050004455
22224457875050004455
23224457875050004455
24224457875050004455
25224457875050004455
26224457875050004455
27224457875050004455
28224457875050004455
29224457875050004455
30224457875050004455
31224457875050004455
32224457875050004455
33224457875050004455
Data Output


??? Its not formatted properly, but is that the jist of it @Jeanpierre ?
Click to expand...
Yes this output file one.
 
Upvote 0
Here is the loop code that I came up with:

VBA Code: 
Sub TestSub1WithLoop()
'
    Dim DataOutputBRowIncrementer   As Long
    Dim DemoLineProcessed           As Long
    Dim LastRow                     As Long
    Dim RowCounter                  As Long
'
    ActiveSheet.Range("C:C").TextToColumns Range("C1"), xlDelimited, _
        xlDoubleQuote, , True, , True, , , _
        FieldInfo:=Array(Array(1, xlTextFormat), Array(2, xlTextFormat), Array(3, xlTextFormat), Array(4, xlTextFormat), Array(5, xlTextFormat)), _
        TrailingMinusNumbers:=True
'
    Sheets.Add(After:=ActiveSheet).Name = "Data Output"
'
    Sheets("Data Output").Range("A1").FormulaR1C1 = "Cell A"            ' Write "Cell A" to cell A1 on Sheet 'Data Output'
    Sheets("Data Output").Range("B1").FormulaR1C1 = "Cell B"            ' Write "Cell B" to cell B1 on Sheet 'Data Output'
    Sheets("Data Output").Range("C1").FormulaR1C1 = "Cell C"            ' Write "Cell C" to cell C1 on Sheet 'Data Output'
'
    Sheets("Data Output").Columns("A:C").ColumnWidth = 11.29            ' Set the width of Columns A - C on the 'Data Output' sheet
'
    LastRow = Sheets("Demo").Range("C" & Rows.Count).End(xlUp).Row      ' Find Last used row in Coulmn C of the 'Demo' sheet
'
    DataOutputBRowIncrementer = 3
    DemoLineProcessed = 0
'
    For RowCounter = 1 To LastRow Step 2
'
        DemoLineProcessed = DemoLineProcessed + 1
'
        If Sheets("Demo").Range("A" & RowCounter) <> "" Then
            Sheets("Demo").Range("C" & (DemoLineProcessed * 2) & ":V" & (DemoLineProcessed * 2)).Copy   ' Copy/Transpose data from 'Demo' sheet to 'Data Output' sheet
            Sheets("Data Output").Range("C" & (RowCounter * 2)).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
'
            Sheets("Data Output").Range("A" & (RowCounter * 2)) = Sheets("Demo").Range("B" & RowCounter) ' Copy 'Demo' sheet Range("B1") to sheet 'Data Output' Range("A2")
        Else
            Sheets("Demo").Range("C" & (RowCounter + 1) & ":V" & (RowCounter + 1)).Copy                 ' Copy/Transpose data from 'Demo' sheet to 'Data Output' sheet
            Sheets("Data Output").Range("C" & (RowCounter * 2)).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        End If
'
        Sheets("Data Output").Range("B" & (RowCounter * 2) & ":B" & ((RowCounter * 2) + DataOutputBRowIncrementer)) = Sheets("Demo").Range("C" & RowCounter)  ' Copy 'Demo' sheet Range("C1") to sheet 'Data Output' Range("B2:B5")
    Next
'
    Sheets("Data Output").Range("A1").Select
End Sub
 
Upvote 0
This should be considerably faster, particularly if the data is fairly large. It also does not require the text to columns on the 'Demo' sheet.

VBA Code: 
Sub Data_Output()
  Dim a As Variant, b As Variant, itm As Variant
  Dim i As Long, k As Long
  
  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 b(k + 1, 1) = a(i, 1)
    For Each itm In Split(a(i + 1, 2), ",")
      k = k + 1
      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)
      .Value = b
      .Columns.AutoFit
    End With
  End With
End Sub
 
Upvote 0
Good day Gentlemen apologies for long delay, WOW, it worked lovely thank you. This did work perfect.

johnnyL said:
Here is the loop code that I came up with:

VBA Code: 
Sub TestSub1WithLoop()
'
    Dim DataOutputBRowIncrementer   As Long
    Dim DemoLineProcessed           As Long
    Dim LastRow                     As Long
    Dim RowCounter                  As Long
'
    ActiveSheet.Range("C:C").TextToColumns Range("C1"), xlDelimited, _
        xlDoubleQuote, , True, , True, , , _
        FieldInfo:=Array(Array(1, xlTextFormat), Array(2, xlTextFormat), Array(3, xlTextFormat), Array(4, xlTextFormat), Array(5, xlTextFormat)), _
        TrailingMinusNumbers:=True
'
    Sheets.Add(After:=ActiveSheet).Name = "Data Output"
'
    Sheets("Data Output").Range("A1").FormulaR1C1 = "Cell A"            ' Write "Cell A" to cell A1 on Sheet 'Data Output'
    Sheets("Data Output").Range("B1").FormulaR1C1 = "Cell B"            ' Write "Cell B" to cell B1 on Sheet 'Data Output'
    Sheets("Data Output").Range("C1").FormulaR1C1 = "Cell C"            ' Write "Cell C" to cell C1 on Sheet 'Data Output'
'
    Sheets("Data Output").Columns("A:C").ColumnWidth = 11.29            ' Set the width of Columns A - C on the 'Data Output' sheet
'
    LastRow = Sheets("Demo").Range("C" & Rows.Count).End(xlUp).Row      ' Find Last used row in Coulmn C of the 'Demo' sheet
'
    DataOutputBRowIncrementer = 3
    DemoLineProcessed = 0
'
    For RowCounter = 1 To LastRow Step 2
'
        DemoLineProcessed = DemoLineProcessed + 1
'
        If Sheets("Demo").Range("A" & RowCounter) <> "" Then
            Sheets("Demo").Range("C" & (DemoLineProcessed * 2) & ":V" & (DemoLineProcessed * 2)).Copy   ' Copy/Transpose data from 'Demo' sheet to 'Data Output' sheet
            Sheets("Data Output").Range("C" & (RowCounter * 2)).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
'
            Sheets("Data Output").Range("A" & (RowCounter * 2)) = Sheets("Demo").Range("B" & RowCounter) ' Copy 'Demo' sheet Range("B1") to sheet 'Data Output' Range("A2")
        Else
            Sheets("Demo").Range("C" & (RowCounter + 1) & ":V" & (RowCounter + 1)).Copy                 ' Copy/Transpose data from 'Demo' sheet to 'Data Output' sheet
            Sheets("Data Output").Range("C" & (RowCounter * 2)).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
        End If
'
        Sheets("Data Output").Range("B" & (RowCounter * 2) & ":B" & ((RowCounter * 2) + DataOutputBRowIncrementer)) = Sheets("Demo").Range("C" & RowCounter)  ' Copy 'Demo' sheet Range("C1") to sheet 'Data Output' Range("B2:B5")
    Next
'
    Sheets("Data Output").Range("A1").Select
End Sub
Click to expand...
 
Upvote 0
Thank you Peter, this was fast. Only thing with this is once it transposes, or moves data, all data needs to be in text format would that be possible incase any number has a 0 in front, this would remove the 0, so if the ID number in columns was 0227733, when run this it becomes 227733.

Other than that this is great.

Peter_SSs said:
This should be considerably faster, particularly if the data is fairly large. It also does not require the text to columns on the 'Demo' sheet.

VBA Code: 
Sub Data_Output()
  Dim a As Variant, b As Variant, itm As Variant
  Dim i As Long, k As Long
 
  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 b(k + 1, 1) = a(i, 1)
    For Each itm In Split(a(i + 1, 2), ",")
      k = k + 1
      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)
      .Value = b
      .Columns.AutoFit
    End With
  End With
End Sub
Click to expand...
 
Upvote 0
Jeanpierre said:
all data needs to be in text format would that be possible incase any number has a 0 in front
Click to expand...
Sure, try this with just one new line added.

Rich (BB code): 
Sub Data_Output()
  Dim a As Variant, b As Variant, itm As Variant
  Dim i As Long, k As Long
  
  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 b(k + 1, 1) = a(i, 1)
    For Each itm In Split(a(i + 1, 2), ",")
      k = k + 1
      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
 
Upvote 0
Absolutely magical thank you. Working like charm.

Peter_SSs said:
Sure, try this with just one new line added.

Rich (BB code): 
Sub Data_Output()
  Dim a As Variant, b As Variant, itm As Variant
  Dim i As Long, k As Long
 
  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 b(k + 1, 1) = a(i, 1)
    For Each itm In Split(a(i + 1, 2), ",")
      k = k + 1
      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
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
Dynamic Address by VBA
Replies
8
Views
212
MikeVol
MikeVol
K
  • Question Question
Increasing row before the macro runs again
Replies
1
Views
230
kbk
K
willow1985
  • Solved
VBA Run-time error 91 - Object variable or With block variable not set when trying to refresh data/Sleep
Replies
4
Views
400
willow1985
willow1985
D
  • Solved
Insert formula in last column macro
2
Replies
13
Views
215
MARK858
MARK858
S
  • Question Question
Macro Formatting to all WS
Replies
4
Views
360
MARK858
MARK858

Forum statistics

Threads
1,224,823
Messages
6,181,176
Members
453,021
Latest member
Justyna P

Share this page

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
Back
Top