Macro that will copy and paste a table and will transpose data and create a loop

[snajam23]

I am trying to create a macro. I need to copy and paste the table from sheet1 into sheet2. The first table is in sheet1 and the second table will be in sheet2. The data should look like the table in sheet2.

Column A will remain constant. Column B will remain constant until all the data points for each time period have been pasted into separate rows. Column C will also remain constant until all data points for each time period have been posted. Column D will remain constant. The time period will be pasted under a column labeled "Time" and continue to repeat according to the values for the corresponding time period. All the values will be posted under a column lableled "Signed Data" and the value for each corresponding month will be pasted in separate rows.

Any help on this would be much appreciated.

Sheet1

Comp_Code	Profit Center	Cost Element	SPECIALID	Jan-18	Feb-18	Mar-18	Apr-18	May-18
WH00	Other/Divest	Cost Of Sales	SHELLSHARE	0.00	0.00	0.00	0.00	0.00
WH00	Other/Divest	Fuel and Power	SHELLSHARE	5.00	5.00	5.00	5.00	5.00
WH00	Other/Divest	Oil (Loss)/Gain	SHELLSHARE	10.00	10.00	10.00	10.00	10.00
WH00	Pipes	Cost Of Sales	SHELLSHARE	0.00	0.00	0.00	0.00	0.00
WH00	Pipes	Fuel and Power	SHELLSHARE	5.00	5.00	5.00	5.00	5.00
WH00	Pipes	Oil (Loss)/Gain	SHELLSHARE	10.00	10.00	10.00	10.00	10.00

<colgroup><col><col><col><col><col span="5"></colgroup><tbody>
</tbody>

Sheet2

Comp_Code	Profit Center	Cost Element	SPECIALID	TIME	SIGNEDDATA
WH00	Other/Divest	Cost Of Sales	SHELLSHARE	2018.01	0.00
WH00	Other/Divest	Cost Of Sales	SHELLSHARE	2018.02	0.00
WH00	Other/Divest	Cost Of Sales	SHELLSHARE	2018.03	0.00
WH00	Other/Divest	Cost Of Sales	SHELLSHARE	2018.04	0.00
WH00	Other/Divest	Cost Of Sales	SHELLSHARE	2018.05	0.00
WH00	Other/Divest	Fuel and Power	SHELLSHARE	2018.01	5.00
WH00	Other/Divest	Fuel and Power	SHELLSHARE	2018.02	5.00
WH00	Other/Divest	Fuel and Power	SHELLSHARE	2018.03	5.00
WH00	Other/Divest	Fuel and Power	SHELLSHARE	2018.04	5.00
WH00	Other/Divest	Fuel and Power	SHELLSHARE	2018.05	5.00
WH00	Other/Divest	Oil (Loss)/Gain	SHELLSHARE	2018.01	10.00
WH00	Other/Divest	Oil (Loss)/Gain	SHELLSHARE	2018.02	10.00
WH00	Other/Divest	Oil (Loss)/Gain	SHELLSHARE	2018.03	10.00
WH00	Other/Divest	Oil (Loss)/Gain	SHELLSHARE	2018.04	10.00
WH00	Other/Divest	Oil (Loss)/Gain	SHELLSHARE	2018.05	10.00
WH00	Pipes	Cost Of Sales	SHELLSHARE	2018.01	0.00
WH00	Pipes	Cost Of Sales	SHELLSHARE	2018.02	0.00
WH00	Pipes	Cost Of Sales	SHELLSHARE	2018.03	0.00
WH00	Pipes	Cost Of Sales	SHELLSHARE	2018.04	0.00
WH00	Pipes	Cost Of Sales	SHELLSHARE	2018.05	0.00
WH00	Pipes	Fuel and Power	SHELLSHARE	2018.01	5.00
WH00	Pipes	Fuel and Power	SHELLSHARE	2018.02	5.00
WH00	Pipes	Fuel and Power	SHELLSHARE	2018.03	5.00
WH00	Pipes	Fuel and Power	SHELLSHARE	2018.04	5.00
WH00	Pipes	Fuel and Power	SHELLSHARE	2018.05	5.00
WH00	Pipes	Oil (Loss)/Gain	SHELLSHARE	2018.01	10.00
WH00	Pipes	Oil (Loss)/Gain	SHELLSHARE	2018.02	10.00
WH00	Pipes	Oil (Loss)/Gain	SHELLSHARE	2018.03	10.00
WH00	Pipes	Oil (Loss)/Gain	SHELLSHARE	2018.04	10.00
WH00	Pipes	Oil (Loss)/Gain	SHELLSHARE	2018.05	10.00

<colgroup><col><col><col><col><col><col></colgroup><tbody>
</tbody>

 

[RCBricker]

Re: Trying to create a Macro that will copy and paste a table and will transpose data and create a loop

try this and let me know

Sub snajam23()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lngrow As Long, lngcol As Long
Dim rng As Range, cell As Range, rngPRO As Range, rngCOST As Range, _
    rngCOL As Range, cellPRO As Range, cellCOST As Range, cellCOL As Range, _
    rngHEAD As Range, rngHEAD2 As Range, rngCOPY As Range
Dim varI As Variant, varJ As Variant
Dim intPRO As Integer, intCOST As Integer, intDATE As Integer, _
    intROW As Integer, intTIME As Integer
Dim strCHK1 As String, strCHK2 As String, strDATE As String

    Set wb = ThisWorkbook
    Set ws1 = wb.Sheets("snajam23 table1")
    Set ws2 = wb.Sheets("snajam23 table2")
    With ws1
        lngrow = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row
        lngcol = ws1.Cells(1, ws1.Columns.Count).End(xlToLeft).Column
        Set rngHEAD = ws1.Range(ws1.Cells(1, 1), ws1.Cells(1, lngcol))
        intPRO = rngHEAD.Find("Profit Center").Column
        intCOST = rngHEAD.Find("Cost Element").Column
        intDATE = rngHEAD.Find("SPECIALID").Column + 1
        
        Set rngPRO = ws1.Range(ws1.Cells(2, intPRO), ws1.Cells(lngrow, intPRO))
        Set rngCOL = ws1.Range(ws1.Cells(rngHEAD.Row, intDATE), _
                ws1.Cells(rngHEAD.Row, lngcol))
        strCHK1 = ""
        strCHK2 = ""
        For Each cellPRO In rngPRO
            strCHK1 = cellPRO.Value
            If Not strCHK1 = cellPRO.Offset(-1).Value Then
                Set rngCOST = ws1.Range(ws1.Cells(cellPRO.Row, intCOST), _
                        ws1.Cells(lngrow, intCOST))
                For Each cellCOST In rngCOST
                    
                        If strCHK1 = cellCOST.Offset(, -1).Value Then
                            With ws2
                                varI = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row + 1
                                
                                varJ = ws2.Cells(1, ws2.Columns.Count).End(xlToLeft).Column
                                Set rngHEAD2 = ws2.Range(ws2.Cells(1, 1), _
                                        ws2.Cells(1, varJ))
                                intTIME = rngHEAD2.Find("TIME").Column
                            End With
                            Set rngCOPY = ws1.Range(ws1.Cells(cellCOST.Row, 1), _
                                    ws1.Cells(cellCOST.Row, intTIME - 1))
            
                            varJ = 0
                            For Each cellCOL In rngCOL
                                rngCOPY.Copy
                                ws2.Range("A" & varI + varJ).PasteSpecial xlPasteAll
                                strDATE = Year(cellCOL.Value) & "." & Month(cellCOL.Value)
                                ws2.Cells(varI + varJ, intTIME).Value = strDATE
            
                                ws1.Cells(cellCOST.Row, cellCOL.Column).Copy
                                ws2.Cells(varI + varJ, intTIME + 1).PasteSpecial xlPasteAll
                                varJ = varJ + 1
                            Next cellCOL
                        Else
                            Exit For
                        End If
                Next cellCOST
            End If
        Next cellPRO
    End With
End Sub

 

[snajam23]

Re: Trying to create a Macro that will copy and paste a table and will transpose data and create a loop

This macro was perfect!

Thank you RCBricker!

 

[snajam23]

Re: Trying to create a Macro that will copy and paste a table and will transpose data and create a loop

Hi All,

Another question regarding the macro in this thread. When i ran the macro with a larger data set it ran very slow. The larger data set had more columns (additional time periods) and more rows going down.

Any idea as to if there is anything in the macro that would cause to run slowly with a larger data set?

Thank you again for any help on this topic!

 

[Fluff]

Re: Trying to create a Macro that will copy and paste a table and will transpose data and create a loop

Is this any quicker

Sub CopyTrans()

   Dim Cl As Range
   Dim Qty As Long
   Dim dt As Variant
   Dim Ary As Variant
   Dim ws1 As Worksheet
   Dim ws2 As Worksheet
Application.ScreenUpdating = False
   Set ws1 = Sheets("Data")
   Set ws2 = Sheets("Sheet2")
   
   dt = Application.Transpose(ws1.Range("E1", ws1.Range("E1").End(xlToRight)))
   ws2.Range("A1:D1").Value = ws1.Range("A1:D1").Value
   ws2.Range("E1:F1").Value = Array("Time", "Signeddata")
   ws2.Columns("E").NumberFormat = "yyyy.mm"
   
   For Each Cl In ws1.Range("A2", ws1.Range("A" & Rows.Count).End(xlUp))
      Qty = Cl.Offset(, 4).End(xlToRight).Column - 4
      ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 4).Resize(Qty).Value = dt
      ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 5).Resize(Qty).Value = Application.Transpose(Cl.Offset(, 4).Resize(, Qty))
      Cl.Resize(, 4).Copy ws2.Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(Qty)
   Next Cl
End Sub

 

[snajam23]

Re: Trying to create a Macro that will copy and paste a table and will transpose data and create a loop

Thank you Fluff ! This macro was perfect for the much larger data set. It ran instantaneously.

 

[Fluff]

Re: Trying to create a Macro that will copy and paste a table and will transpose data and create a loop

Glad we could help & thanks for the feedback