Help making a macro to transpose data

[lwilt]

I'm trying to make a new macro for the changes in my data set to transpose my data. I attached an excel file so you can see how it looks currently. I would like it so that each item only occurs in one single row and the data is then going horizontal across the page.

 

[Luke M]

Hi lwilt,

I see what you have now, but can you show us what you want it to look like at the end?

 

[lwilt]

absolutely...just attached what I would like the final outcome to look like

 

[Luke M]

Try this:

Sub TransposeData()
Dim lastRow As Long
Dim recRow As Long
Dim i As Long
Dim curSKU As String
Dim destWS As Worksheet
Dim sourceWS As Worksheet

Application.ScreenUpdating = False

Set sourceWS = ActiveSheet
Set destWS = ThisWorkbook.Worksheets.Add

curSKU = ""
recRow = 1
With sourceWS
    destWS.Range("A1") = .Range("A1").Value
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
   
    For i = 2 To lastRow
        'Check if new SKU
        If .Cells(i, 1).Value <> curSKU Then
            curSKU = .Cells(i, 1).Value
            recRow = recRow + 1
            destWS.Cells(recRow, 1).Value = curSKU
        End If
        If .Cells(i, 2).Value <> "" Then
            .Cells(i, 2).Resize(1, 2).Copy
            destWS.Cells(recRow, .Columns.Count).End(xlToLeft).Offset(0, 1).PasteSpecial xlPasteValues
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
      
End Sub

 

[Marc L]

Hi !

Another way with result in source worksheet :​

Sub Demo()
Dim Rg As Range
Application.ScreenUpdating = False

With Sheet4.Cells(1).CurrentRegion.Rows
               Set Rg = .Parent.Cells(.Columns.Count + 2).Resize(2)
    .Cells(1).Copy Rg(1)
     .Item(2).Copy Rg(2)

    For R& = 3 To .Count
        With .Item(R)
                       V = Application.Match(.Cells(1).Value, Rg.Columns(1), 0)
            If IsError(V) Then
                .Copy Rg(1).Offset(Rg.Rows.Count):  Set Rg = Rg.CurrentRegion
            ElseIf Application.CountA(.Cells) > 1 Then
                .Range("B1:C1").Copy .Parent.Cells(V, Columns.Count).End(xlToLeft)(1, 2)
            End If
        End With
    Next

    Set Rg = Nothing
    .Parent.Columns(1).Resize(, .Columns.Count + 1).Delete
End With
End Sub

Do you like it ? So thanks to click on bottom right Like !
​