Copper Contributor

Nov 20, 2023

Solved

VBA for transposing some data to a new sheet

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.

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).

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

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

7 Replies

HansVogelaar

MVP

Nov 21, 2023

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

Logaraj Sekar

Iron Contributor

Nov 21, 2023

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

TeivaC
Copper Contributor
Nov 21, 2023
Thanks a lot Logaraj, it works 🙂

Riny_van_Eekelen
Platinum Contributor
Nov 21, 2023
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.

TeivaC.xlsx25 KB
- TeivaC
  Copper Contributor
  Nov 21, 2023
  Thank you Riny. I'll look into that too.
Logaraj Sekar
Iron Contributor
Nov 21, 2023
Can you send the sample data in excel file with exact sheet name.
HansVogelaar
MVP
Nov 21, 2023
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.

Forum Discussion

VBA for transposing some data to a new sheet

7 Replies

Resources