VBA transpose row of dates, quantities and part number into 3 columns

[adicenso14]

Hello,

I am a VBA beginner and would like some assistance on how to create a VBA that can transpose rows of data into columns on a loop

I have data on Sheet1 that contains a Part Number in column A and associated dates and quantities in columns U:AF

I need this data to be transposed onto Sheet2, so that the dates are transposed into column E and the quantities are transposed into column F

The Part Number will need to repeat into Column C on Sheet2 in each row until all dates/quantities have been transposed, which in this case will always be 12 rows

This will need to run through all part numbers listed on Sheet1 until no more rows of data

See attached image of Sheet1 where data is located and desired output in Sheet2

 

[mumps]

Try:

Sub transposeData()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, prod As Range
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    For Each prod In srcWS.Range("A3:A" & LastRow)
        With desWS
            .Cells(.Rows.Count, "C").End(xlUp).Offset(1).Resize(12).Value = prod
            .Cells(.Rows.Count, "E").End(xlUp).Offset(1).Resize(12).Value = Application.Transpose(srcWS.Range("U2:AF2"))
            .Cells(.Rows.Count, "F").End(xlUp).Offset(1).Resize(12).Value = Application.Transpose(srcWS.Range("U" & prod.Row & ":AF" & prod.Row))
        End With
    Next prod
    Application.ScreenUpdating = True
End Sub

 

[johnnyL]

Here is the array approach I came up with:

Sub Test1()
'
    Dim startTime                   As Single
'
    startTime = Timer                                                                   ' Start the Stop watch
'
    Application.ScreenUpdating = False                                                  ' Turn ScreenUpdating off
'
    Dim DestinationArraysRow    As Long
    Dim LastRowInColumnA        As Long
    Dim ColumnLoop              As Long
    Dim RowLoop                 As Long
    Dim DateArray               As Variant
    Dim DestinationArray1       As Variant
    Dim DestinationArray2       As Variant
    Dim SourceArray             As Variant
    Dim wsDestination           As Worksheet
    Dim wsSource                As Worksheet
'
    Set wsSource = Sheets("Sheet1")                                                     ' <--- Set this to the source sheet name
    Set wsDestination = Sheets("Sheet2")                                                ' <--- Set this to the destination sheet name
'
    LastRowInColumnA = wsSource.Range("A" & wsSource.Rows.Count).End(xlUp).Row          ' Returns a Row Number
'
    DateArray = wsSource.Range("U2:AF2")                                                ' Load Dates into DateArray
    SourceArray = wsSource.Range("A3:AF" & LastRowInColumnA)                            ' Load data from source sheet into SourceArray
'
    ReDim DestinationArray1(1 To UBound(SourceArray) * 12)                              ' Set the number of rows in DestinationArray1
    ReDim DestinationArray2(1 To UBound(SourceArray) * 12, 1 To 2)                      ' Set the number of rows and columns in DestinationArray2
'
    DestinationArraysRow = 0                                                            ' Initialize DestinationArraysRow
'
    For RowLoop = LBound(SourceArray) To UBound(SourceArray)                            ' Loop through rows of source data
        For ColumnLoop = LBound(SourceArray, 2) To UBound(SourceArray, 2)               '   Loop through columns of source data
            Select Case ColumnLoop
                Case 21 To 32                                                           '           If column # found then ...
                    DestinationArraysRow = DestinationArraysRow + 1                     '               Increment DestinationArraysRow
'
                    DestinationArray1(DestinationArraysRow) = SourceArray(RowLoop, 1)                   '       Save Product # into DestinationArray1
                    DestinationArray2(DestinationArraysRow, 1) = "1-" & DateArray(1, ColumnLoop - 20)   '       Save Date into DestinationArray2 slot 1
                    DestinationArray2(DestinationArraysRow, 2) = SourceArray(RowLoop, ColumnLoop)       '       Save Quantity into DestinationArray2 slot 2
            End Select
        Next                                                                                            '   Loop back
    Next                                                                                                ' Loop back
'
    wsDestination.Range("C1").Resize(UBound(DestinationArray1), 1) = Application.Transpose(DestinationArray1)   ' Display Product #s
    wsDestination.Range("E1").Resize(UBound(DestinationArray2, 1), 2) = DestinationArray2                       ' Display Dates and Quantities
'
    Application.ScreenUpdating = True                                                                           ' Turn ScreenUpdating back on
'
    Debug.Print "Time to complete = " & Timer - startTime & " seconds."                                         ' Display the time elapsed to the user (Ctrl-G)
End Sub

 

[DanteAmor]

Hi and Welcome to MrExcel

If in column D, you always have the word "Period", try the following:

Sub TransposeData()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  a = Sheets("Sheet1").Range("A1:AF" & Sheets("Sheet1").Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1) * 12, 1 To 4)
  For i = 3 To UBound(a, 1)
    For j = 21 To 32    'U to AF
      k = k + 1
      b(k, 1) = a(i, 1)
      b(k, 2) = "Period"
      b(k, 3) = a(2, j)
      b(k, 4) = a(i, j)
    Next
  Next
  Sheets("Sheet2").Range("C1").Resize(k, 4).Value = b
End Sub