Changing one row into x rows by 10 columns - excel

Question

**'Dim raport As Worksheet
'Dim daty As String
'Dim lcolumn As Long
'Dim mycolaaa As String
'Dim dataT As Variant
'Set raport = ActiveWorkbook.Sheets("sheet1")
'raport.Activate
'lcolumn = raport.Cells(1, Columns.Count).End(xlToLeft).Column
'daty = ("A1:xy1")
'With raport
'raport.Range(daty).Select
'End With
'Selection.Copy
'dataT = Application.Transpose(Data)
'With tarws
'CopyRangeAddress = .Range("A2:A100").Address
' .Range(CopyRangeAddress).PasteSpecial xlPasteValues
'.Range(CopyRangeAddress).PasteSpecial xlPasteFormats
'.Range(CopyRangeAddress).PasteSpecial xlPasteColumnWidths
'End With
srcws.Activate
'With srcws
'.Range(sortrangeaddress).Select
'End With
'Selection.Copy
'Paste the Sort Range on to the target worksheet
'The CopyRangeAddress will be A1 through the last Row
'and column 2 -- so something like A1:B2
'With tarws
'CopyRangeAddress = .Range(.Cells(pasteRow, pasteCol), _
'.Cells(pasteRow + lrow - 2, 2)).Address
'.Range(CopyRangeAddress).PasteSpecial xlPasteValues
'.Range(CopyRangeAddress).PasteSpecial xlPasteFormats
'.Range(CopyRangeAddress).PasteSpecial xlPasteColumnWidths
'End With**
How to add "daty" cells instead of sortrangeadress? It is data from source worksheet in one row as header of below cells that you helped me with transposing. Thank you a lot for previous answers!

Answer 1

From your pictures it looks like you are attempting to un-pivot a pivot table. Your best bet to tackle this is to create smaller ranges for each "date" groupings. The code below provides an example of how to move through the groupings.
Option Explicit
Public Sub Example()
Const firstDataCell As Long = 3 'Column C
Const columnsInDataGroup As Long = 10
Const DataRowStart As Long = 2 'Row 2
'Worksheet with the source data
Dim srcWs As Worksheet
Set srcWs = ActiveWorkbook.Sheets("Sheet1")
'Worksheet to write data to
Dim tarWs As Worksheet
Set tarWs = ActiveWorkbook.Sheets("Sheet2")
'Get the last row of data
Dim lRow As Long
lRow = LastRow(srcWs)
'Get the last column containing data
Dim lCol As Long
lCol = LastColumn(srcWs)
'This are the first columns you seem to
'want to sort the data on
Dim SortRangeAddress As String
SortRangeAddress = "A2:B" & Trim(CStr(lRow))
'This variable will contain the address of
'each Date Data Group as your macro
'loops across the columns
Dim dateDataGroupRangeAddress As String
Dim row As Long
Dim col As Long
Dim pasteRow As Long: pasteRow = 1
Dim pasteCol As Long: pasteCol = 1
Dim CopyRangeAddress As String
For col = firstDataCell To lCol Step columnsInDataGroup
'Copy the Sort Range from the source worksheet to
'the target worksheet.
With srcWs
.Range(SortRangeAddress).Select
End With
Selection.Copy
'Paste the Sort Range on to the target worksheet
'The CopyRangeAddress will be A1 through the last Row
'and column 2 -- so something like A1:B2
With tarWs
CopyRangeAddress = .Range(.Cells(pasteRow, pasteCol), _
.Cells(pasteRow + lRow - 2, 2)).Address
.Range(CopyRangeAddress).PasteSpecial xlPasteValues
End With
'Copy the next source date data group. The width of the selection
'is determine by columnsInDataGroup constant set above less 1
'Think of the first .Cells as 1 and the second .Cells as
'columnsInDataGroup - 1.
With srcWs
dateDataGroupRangeAddress = .Range(.Cells(DataRowStart, col), _
.Cells(lRow, col + columnsInDataGroup - 1)).Address
.Range(dateDataGroupRangeAddress).Select
End With
Selection.Copy
'Paste the next source date date group to the target worksheet
'CopyRangeAddress here will move 2 columns over from the
'Start of the sort data range (Columns A & B) to start the
'paste in column C
With tarWs
CopyRangeAddress = .Range(.Cells(pasteRow, pasteCol + 2), _
.Cells(pasteRow + lRow - 2, columnsInDataGroup + 2)).Address
.Range(CopyRangeAddress).PasteSpecial xlPasteValues
End With
pasteRow = pasteRow + lRow - 1
Next col
End Sub
Function LastRow(ByRef sh As Worksheet)
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).row
End Function
Function LastColumn(ByRef sh As Worksheet)
LastColumn = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
End Function