VBA or Macro with Loop

[Coenieh]

Good day All,

I have about 4500 records in an excel spreadsheet, with each record in a single row. Each record has a value for a specific quarter of the year. I need to transpose these quarterly values to have each on a separate row but with all the other information also captured in that row. I am very unsure of how create either a VBA or macro that will convert all 4500+ records to the new format myself. Any assistance on how to achieve this will be greatly appreciated. If needed I can upload a sample of the spreadsheet. Thank you in advance for your help.

 

[Cubist]

Try this on a copy.

Sub UnpivotData()

    Dim lastRow As Long
    Dim i As Long
    Dim pasteRow As Range
    Dim dataRng As Range
    Dim copyRng As Range
    Dim destRng As Range
    Dim j As Long
    
    Application.ScreenUpdating = False
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set dataRng = Range("A2:J" & lastRow)
    Set pasteRow = Cells(lastRow + 2, "A")
    
    For i = 1 To dataRng.Rows.Count

        Set copyRng = Range(Cells(dataRng.Row + i - 1, "G"), Cells(dataRng.Row + i - 1, "J"))
        copyRng.Copy

        pasteRow.Offset((i - 1) * 4, 6).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        Application.CutCopyMode = False
    Next i

    For i = 1 To dataRng.Rows.Count
        For j = 1 To 4
            Set copyRng = Range(Cells(dataRng.Row + i - 1, "A"), Cells(dataRng.Row + i - 1, "F"))
            Set destRng = pasteRow.Offset((i - 1) * 4 + j - 1, 0).Resize(1, 6)
            destRng.Value = copyRng.Value
        Next j
    Next i
    Application.ScreenUpdating = True
    MsgBox "Done", vbInformation
End Sub

 

[Coyotex3]

Another option

Sub Coenieh()
Dim sh1 As Worksheet, sht As Worksheet
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  Dim LR As Long

Sheets.Add.Name = "Temp"  'adds a sheet named Temp
  Set sh1 = Sheets("Sheet1")
  Set sht = Sheets("Temp")
 
  LR = sh1.Range("A" & Rows.Count).End(xlUp).Row

  a = sh1.Range("A1:J" & LR).Value
  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 8)
 
  For i = 2 To UBound(a, 1)
      For j = 7 To 10
        k = k + 1
            b(k, 1) = a(i, 1)
            b(k, 2) = a(i, 2)
            b(k, 3) = a(i, 3)
            b(k, 4) = a(i, 4)
            b(k, 5) = a(i, 5)
            b(k, 6) = a(i, 6)
            b(k, 7) = a(1, j)
            b(k, 8) = a(i, j)
  
    Next
   Next
   sht.Range("A2").Resize(k, 8).Value = b
   sht.Range("A1:H1").Value = Array("Period", "Site", "SEG", "Exposure", "Containment", "Target", "Quarter", "Quota")

End Sub

 

[Coenieh]

Try this on a copy.

Sub UnpivotData()

    Dim lastRow As Long
    Dim i As Long
    Dim pasteRow As Range
    Dim dataRng As Range
    Dim copyRng As Range
    Dim destRng As Range
    Dim j As Long
   
    Application.ScreenUpdating = False
    lastRow = Cells(Rows.Count, "A").End(xlUp).Row
    Set dataRng = Range("A2:J" & lastRow)
    Set pasteRow = Cells(lastRow + 2, "A")
   
    For i = 1 To dataRng.Rows.Count

        Set copyRng = Range(Cells(dataRng.Row + i - 1, "G"), Cells(dataRng.Row + i - 1, "J"))
        copyRng.Copy

        pasteRow.Offset((i - 1) * 4, 6).PasteSpecial Paste:=xlPasteAll, Transpose:=True
        Application.CutCopyMode = False
    Next i

    For i = 1 To dataRng.Rows.Count
        For j = 1 To 4
            Set copyRng = Range(Cells(dataRng.Row + i - 1, "A"), Cells(dataRng.Row + i - 1, "F"))
            Set destRng = pasteRow.Offset((i - 1) * 4 + j - 1, 0).Resize(1, 6)
            destRng.Value = copyRng.Value
        Next j
    Next i
    Application.ScreenUpdating = True
    MsgBox "Done", vbInformation
End Sub

Thank You Cubist,

I appreciate your quick response. The VBA worked good, except it did not create the Quarter column, but that can be solved easily.

Kind Regards

Coenieh

 

[Coenieh]

Another option

Sub Coenieh()
Dim sh1 As Worksheet, sht As Worksheet
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  Dim LR As Long

Sheets.Add.Name = "Temp"  'adds a sheet named Temp
  Set sh1 = Sheets("Sheet1")
  Set sht = Sheets("Temp")
 
  LR = sh1.Range("A" & Rows.Count).End(xlUp).Row

  a = sh1.Range("A1:J" & LR).Value
  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 8)
 
  For i = 2 To UBound(a, 1)
      For j = 7 To 10
        k = k + 1
            b(k, 1) = a(i, 1)
            b(k, 2) = a(i, 2)
            b(k, 3) = a(i, 3)
            b(k, 4) = a(i, 4)
            b(k, 5) = a(i, 5)
            b(k, 6) = a(i, 6)
            b(k, 7) = a(1, j)
            b(k, 8) = a(i, j)
 
    Next
   Next
   sht.Range("A2").Resize(k, 8).Value = b
   sht.Range("A1:H1").Value = Array("Period", "Site", "SEG", "Exposure", "Containment", "Target", "Quarter", "Quota")

End Sub

Thank you Coyotex3,

Really appreciate your quick response and your solution did exactly what I was looking for.

Kind Regards

Coenieh

 

[kvsrinivasamurthy]

Another way

Sub Macro1()
Dim A, Ary, T&
Dim RstRng As Range

A = Range("A1").CurrentRegion
Ary = Array("Q1", "Q2", "Q3", "Q4")
Set RstRng = Range("A10")                 ' can be changed as required
RstRng.CurrentRegion.Clear
Range("A1:H1").Copy RstRng
RstRng.Offset(0, 6) = "Quarter": RstRng.Offset(0, 7) = "Quota"
For T = 2 To UBound(A, 1)
With RstRng.Offset(1 + 4 * (T - 2), 0)
    .Resize(4, 6) = WorksheetFunction.Index(A, T, 0)
    .Offset(0, 6).Resize(4, 1) = WorksheetFunction.Transpose(Ary)
    .Offset(0, 7).Resize(4, 1) = WorksheetFunction.Transpose(Array(A(T, 7), A(T, 8), A(T, 9), A(T, 10)))
End With
Next T
RstRng.CurrentRegion.Borders.LineStyle = xlContinuous
End Sub

 

[Coyotex3]

Thank you Coyotex3,

Really appreciate your quick response and your solution did exactly what I was looking for.

Kind Regards

Coenieh

Happy to help & thanks for the feedback!