VBA-Macro Help with copy data from 1sheet into another sheet multiple times

[kishu111]

Hi Mr. Excel,

I need a logic that would copy Sheet1 (Data Table) into Sheet2

Sheet2 (End Result should look like this)
In this sheet, MaterialA should be repeated 13 times and each of the months values should be copied vertically against the respective month.
I needed help on how to do this in VBA? (simplest possible way, so this sheet can be reused.)

Thank you in advance for all or any help you can provide.

Regards,

Kishu111

 

[kishu111]

I am using Office Standard 2016

 

[kishu111]

Hi Mr. Excel,

I need a logic that would copy Sheet1 (Data Table) into Sheet2

View attachment 64682

Sheet2 (End Result should look like this)
In this sheet, MaterialA should be repeated 13 times and each of the months values should be copied vertically against the respective month.
I needed help on how to do this in VBA? (simplest possible way, so this sheet can be reused.)
View attachment 64683

Thank you in advance for all or any help you can provide.

Regards,

Kishu111

Wanted to see if anyone could please help with this?

 

[Alex Blakenburg]

See if this works for you:

Sub TransposeData()

    Dim srcSht As Worksheet, destSht As Worksheet
    Dim srcRng As Range, destRng As Range
    Dim srcArr As Variant
    Dim destArr() As Variant
    Dim i As Long, j As Long, destCnt As Long
    Dim sItem As String, sMth As String
    
    Set srcSht = Worksheets("Data")             '<-- Change to your sheet name
    Set destSht = Worksheets("Result")          '<-- Change to your sheet name
    Set srcRng = srcSht.Range("A1").CurrentRegion
    Set destRng = destSht.Range("A1")
    srcArr = srcRng.Value
    destCnt = 0
    
    ReDim destArr(1 To UBound(srcArr, 1) * UBound(srcArr, 2), 1 To 3)
    
    For i = 2 To UBound(srcArr)
        sItem = srcArr(i, 1)
        For j = 1 To 13
            destCnt = destCnt + 1
            sMth = srcArr(1, j + 1)
            destArr(destCnt, 1) = sItem
            destArr(destCnt, 2) = sMth
            destArr(destCnt, 3) = srcArr(i, j + 1)
        Next j
    Next i

    destRng.Offset(1).Resize(UBound(destArr, 1), UBound(destArr, 2)).Value = destArr
    destRng.Resize(1, 3).Value = Array("Material", "Volume Per", "Value")
    destRng.Resize(1, 3).Font.Bold = True
    destRng.CurrentRegion.Columns.AutoFit
    
End Sub

 

[kvsrinivasamurthy]

Try this faster code

Sub TransposeData()
Dim LR1 As Long, T As Long
Dim A, B
Application.ScreenUpdating = False
With Sheets("Sheet1").Range("A1")
A = .CurrentRegion.Offset(0, 1)
LR1 = .Offset(1, 0).End(xlDown).Row
B = .Range("A2:A" & LR1)
End With

With Sheets("Sheet2")
.Range("A1").CurrentRegion.Clear
.Range("A1:C1").Value = Array("Material", "Volume for", "Value")
    For T = 1 To LR1 - 1
    .Range("A2").Offset(12 * (T - 1), 0).Resize(12, 1).Value = B(T, 1)
    .Range("B2").Offset(12 * (T - 1), 0).Resize(12, 1).Value = WorksheetFunction.Transpose(WorksheetFunction.Index(A, 1, 0))
    .Range("C2").Offset(12 * (T - 1), 0).Resize(12, 1).Value = WorksheetFunction.Transpose(WorksheetFunction.Index(A, T + 1, 0))
    Next T
End With
Application.ScreenUpdating = True
End Sub

 

[kvsrinivasamurthy]

Improved Code

Sub TransposeData()
Dim LR1 As Long, T As Long
Dim A, B, C
Application.ScreenUpdating = False
With Sheets("Sheet1").Range("A1")
LR1 = .Offset(1, 0).End(xlDown).Row
A = .Range("A2:A" & LR1)
B = WorksheetFunction.Transpose(.Range("B1:M1"))
C = WorksheetFunction.Transpose(.Range("B2:M" & LR1))
End With

With Sheets("Sheet2")
.Range("A1").CurrentRegion.Clear
.Range("A1:C1").Value = Array("Material", "Volume for", "Value")
    
    For T = 1 To LR1 - 1
    With .Range("A" & 2 + (12 * (T - 1)))
    .Resize(12, 1).Value = A(T, 1)
    .Offset(0, 1).Resize(12, 1).Value = B
    .Offset(0, 2).Resize(12, 1).Value = WorksheetFunction.Index(C, 0, T)
    End With
    Next T
End With
Application.ScreenUpdating = True
End Sub

 

[Alex Blakenburg]

Try this faster code

That was a pretty bold and untested statement.
Logically your code was never going to be faster.
The original code had 1 read and 1 write.
Your code has 1 read and "LR-1" writes ie For T = 1 To LR1 - 1

On 2,000 lines my code took < 0.2 secs. Your latest code 10 secs.
At 20k records my code took 1.8 secs, after about 5k your code takes that long that I ended up killing it.

PS: Although I agree that I wouldn't want the total in my output, the original sample indicated it wanted the Annual Total, you are not picking up that column.
(I just noticed that I didn't rename it and it is still called Grand Total in my output)