SOLVED

VBA for transposing some data to a new sheet

Copper Contributor

Hi everyone,

 

I'm a total beginner in VBA and am trying to transpose some data from one sheet to another. 

I have different items in column B, with corresponding quantities and sizes in column O to U.

TeivaC_0-1700522563206.png

 

I would like to create a macro that will create a new tab and organize the data vertically, duplicating each item' specifications in rows (from column A to F in the source sheet), transpose the sizes in cells O7 to U7 in the source sheet to column G in target sheet, and transpose the quantities correspondingly (as below).

 

TeivaC_1-1700523171846.png

 

Here's the code I have so far but it doesn't give me the expected result. May I ask for your help please.

Sub DuplicateProductsForSizes()

    Dim SourceSheet As Worksheet

    Dim TargetSheet As Worksheet

    Dim SourceRange As Range

    Dim TargetRange As Range

    Dim SourceRow As Range

    Dim ProductRange As Range

    Dim SizeColumn As Range

    Dim Size As Variant

   

    Set SourceSheet = ThisWorkbook.Sheets("BL")

    Set TargetSheet = ThisWorkbook.Sheets.Add

    TargetSheet.Name = "Receiving BL"

        Set SourceRange = SourceSheet.UsedRange

    Set TargetRange = TargetSheet.Range("A1")

    SourceSheet.Range("A7:F7").Copy TargetRange.Resize(1, 6)

    TargetSheet.Range("G1").Value = "Qty"

    Set TargetRange = TargetSheet.Range("A2")

    For Each SourceRow In SourceRange.Rows

        Set ProductRange = SourceRow.Cells(8, 1).Resize(1, 6)

        For Each SizeColumn In SourceRow.Cells(8, 15).Resize(1, 7) ' Columns O to U

            Size = SizeColumn.Value

            If Not IsEmpty(Size) Then

                ProductRange.Copy TargetRange.Resize(1, 6)

                TargetRange.Cells(1, 7).Value = Size

                Set TargetRange = TargetRange.Offset(1, 0)

            End If

        Next SizeColumn

    Next SourceRow

End Sub

 

 

Thanks in advance.

 

Teiva

7 Replies

@TeivaC 

Could you attach a small sample workbook demonstrating the problem (without sensitive data), or if that is not possible, make it available through OneDrive, Google Drive, Dropbox or similar? Alternatively, you can attach it to a private message to me. Thanks in advance.

Can you send the sample data in excel file with exact sheet name.

@TeivaC I'd suggest you learn Power Query in stead. This is a 2 step process and is achieved by clicking in the user interface only.

Google for "Unpivot columns Power Query" and you'll find many resources leading you from start to finish. No coding skills required.

The attached file contains data that I copied from your screenshot (Data, From Picture) and the unpivoted result in a separate sheet.

 

 

Sub DuplicateProductsForSizes()
    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim sourceRange As Range
    Dim targetRange As Range
    Dim SourceRow As Range
    Dim ProductRange As Range
    Dim SizeColumn As Range
    Dim Size As Variant
    
    Set SourceSheet = ThisWorkbook.Sheets("BL")
    Set TargetSheet = ThisWorkbook.Sheets.Add
    
    TargetSheet.Name = "Receiving BL"
    
    Set sourceRange = SourceSheet.UsedRange
    Set targetRange = TargetSheet.Range("A1")
    
    SourceSheet.Range("A7:F7").Copy targetRange.Resize(1, 6)
    TargetSheet.Range("G1").Value = "Qty"
    TargetSheet.Range("H1").Value = "Size"
    
    Set targetRange = TargetSheet.Range("A2")
    For Each SourceRow In sourceRange.Rows
        Set ProductRange = SourceRow.Cells(8, 1).Resize(1, 6)
        For Each SizeColumn In SourceRow.Cells(8, 15).Resize(1, 7) ' Columns O to U
            Size = SizeColumn.Value
            If Not IsEmpty(Size) Then
                ProductRange.Copy targetRange.Resize(1, 6)
                targetRange.Cells(1, 7).Value = Size
                Set targetRange = targetRange.Offset(1, 0)
            End If
        Next SizeColumn
    Next SourceRow
    
    Sheets("BL").Range("O7:U7").Copy
    Sheets("Receiving BL").Range("H2:H211").PasteSpecial Transpose:=True
End Sub

@TeivaC 

best response confirmed by TeivaC (Copper Contributor)
Solution

@TeivaC 

A variant:

Sub DuplicateProductsForSizes()
    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim SourceRange As Range
    Dim TargetRange As Range
    Dim SourceRow As Range
    Dim ProductRange As Range
    Dim SizeColumn As Long
    Dim Size As Variant
    
    Application.ScreenUpdating = False
    Set SourceSheet = ThisWorkbook.Sheets("BL")
    On Error Resume Next
    Set TargetSheet = ThisWorkbook.Worksheets("Receiving BL")
    On Error GoTo 0
    If TargetSheet Is Nothing Then
        Set TargetSheet = ThisWorkbook.Sheets.Add
        TargetSheet.Name = "Receiving BL"
    Else
        TargetSheet.UsedRange.Clear
    End If
    Set TargetRange = TargetSheet.Range("A1")
    SourceSheet.Range("A7:F7").Copy TargetRange.Resize(1, 6)
    TargetSheet.Range("G1:H1").Value = Array("Size", "Qty")
    Set TargetRange = TargetSheet.Range("A2")
    Set SourceRange = SourceSheet.Range("A8")
    Do While SourceRange.Value <> 0
        Set ProductRange = SourceRange.Resize(1, 6)
        For SizeColumn = 15 To 21 ' O to U
            Size = SourceRange.Offset(0, SizeColumn - 1)
            If Size <> 0 Then
                ProductRange.Copy TargetRange.Resize(1, 6)
                TargetRange.Offset(0, 6).Value = SourceSheet.Cells(7, SizeColumn).Value
                TargetRange.Offset(0, 7).Value = Size
                Set TargetRange = TargetRange.Offset(1, 0)
            End If
        Next SizeColumn
        Set SourceRange = SourceRange.Offset(1, 0)
    Loop
    TargetSheet.Range(TargetSheet.Range("F1"), TargetRange.Offset(-1, 5)).Copy
    TargetSheet.Range(TargetSheet.Range("G1"), TargetRange.Offset(-1, 7)).PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
Thank you Riny. I'll look into that too.
Thanks a lot Logaraj, it works :)
1 best response

Accepted Solutions
best response confirmed by TeivaC (Copper Contributor)
Solution

@TeivaC 

A variant:

Sub DuplicateProductsForSizes()
    Dim SourceSheet As Worksheet
    Dim TargetSheet As Worksheet
    Dim SourceRange As Range
    Dim TargetRange As Range
    Dim SourceRow As Range
    Dim ProductRange As Range
    Dim SizeColumn As Long
    Dim Size As Variant
    
    Application.ScreenUpdating = False
    Set SourceSheet = ThisWorkbook.Sheets("BL")
    On Error Resume Next
    Set TargetSheet = ThisWorkbook.Worksheets("Receiving BL")
    On Error GoTo 0
    If TargetSheet Is Nothing Then
        Set TargetSheet = ThisWorkbook.Sheets.Add
        TargetSheet.Name = "Receiving BL"
    Else
        TargetSheet.UsedRange.Clear
    End If
    Set TargetRange = TargetSheet.Range("A1")
    SourceSheet.Range("A7:F7").Copy TargetRange.Resize(1, 6)
    TargetSheet.Range("G1:H1").Value = Array("Size", "Qty")
    Set TargetRange = TargetSheet.Range("A2")
    Set SourceRange = SourceSheet.Range("A8")
    Do While SourceRange.Value <> 0
        Set ProductRange = SourceRange.Resize(1, 6)
        For SizeColumn = 15 To 21 ' O to U
            Size = SourceRange.Offset(0, SizeColumn - 1)
            If Size <> 0 Then
                ProductRange.Copy TargetRange.Resize(1, 6)
                TargetRange.Offset(0, 6).Value = SourceSheet.Cells(7, SizeColumn).Value
                TargetRange.Offset(0, 7).Value = Size
                Set TargetRange = TargetRange.Offset(1, 0)
            End If
        Next SizeColumn
        Set SourceRange = SourceRange.Offset(1, 0)
    Loop
    TargetSheet.Range(TargetSheet.Range("F1"), TargetRange.Offset(-1, 5)).Copy
    TargetSheet.Range(TargetSheet.Range("G1"), TargetRange.Offset(-1, 7)).PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

View solution in original post