Data Copy and Transpose

[decent_boy]

Hi,

Data below in Sheet1 needs to be transposed manually to Result Sheet one by one, so I need a macro to automate this process

test.xlsm
	A	B	C	D	E	F	G
1	STYLE NUMBER	SIZING
2		XS	S	M	L	XL	XXL
3	S243001G		1	1	1	1	1
4	S243002L	1	1	1	1	1	1
5	S243003W		1	1	1	1	1
6	TEES		S	M	L	XL	XXL
7	S241001B		1	1	1	1	1
8	S241002T		1	1	1	1	1
9	PANTS		S	M	L	XL	XXL
10	S244051B		1	1	1	1	1
11	S244052G		1	1	1	1	1
12	SWEATERS	XS	S	M	L	XL	XXL
13	S247001A	1	1	1	1	1	1
14	JACKETS	O/S
15	S248001B	1
16	HATS	O/S
17	C995005B	1
Sheet1

The Result I want is like that

test.xlsm
	A	B
1	SKU	QTY
2	S243001G-S	1
3	S243001G-M	1
4	S243001G-L	1
5	S243001G-XL	1
6	S243001G-XXL	1
7	S243003W-S	1
8	S243003W-M	1
9	S243003W-L	1
10	S243003W-XL	1
11	S243003W-XXL	1
12	S241001B-S	1
13	S241001B-M	1
14	S241001B-L	1
15	S241001B-XL	1
16	S241001B-XXL	1
17	S241002T-S	1
18	S241002T-M	1
19	S241002T-L	1
20	S241002T-XL	1
21	S241002T-XXL	1
22	S244051B-S	1
23	S244051B-M	1
24	S244051B-L	1
25	S244051B-XL	1
26	S244051B-XXL	1
27	S244052G-S	1
28	S244052G-M	1
29	S244052G-L	1
30	S244052G-XL	1
31	S244052G-XXL	1
32	S247001A-XS	1
33	S247001A-S	1
34	S247001A-M	1
35	S247001A-L	1
36	S247001A-XL	1
37	S247001A-XXL	1
38	S248001B-O/S	1
39	C995005B-O/S	1
Result

 

[kevin9999]

Try the following on a copy of your workbook.

Option Explicit
Sub Decent_Boy()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("Sheet1")  '<~~ *** Change sheet names to suit ***
    Set ws2 = Worksheets("Result")
    Dim LRow As Long, LCol As Long
    LRow = ws1.Cells(Rows.Count, "A").End(xlUp).Row
    LCol = ws1.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    
    Dim a, b, i As Long, j As Long, k As Long, n As Long, x As Long
    a = ws1.Range(ws1.Cells(2, 1), ws1.Cells(LRow, LCol))
    x = WorksheetFunction.CountA(ws1.Range(ws1.Cells(2, 1), ws1.Cells(LRow, LCol)))
    ReDim b(1 To x, 1 To 2)
    k = 1: n = 1
    For i = 1 To UBound(a, 1)
        For j = 2 To UBound(a, 2)
            If (a(i, j)) <> "" And IsNumeric(a(i, j)) Then
                Do Until (a(i - n, j)) <> "" And IsNumeric(a(i - n, j)) = False
                    n = n + 1
                Loop
                b(k, 1) = a(i, 1) & "-" & a(i - n, j)
                b(k, 2) = a(i, j)
                n = 1
                k = k + 1
            End If
        Next j
    Next i
    
    With ws2
        .Range("A:B").ClearContents
        .Range("A1").Resize(, 2).Value = Array("SKU", "QTY")
        .Range("A2").Resize(UBound(b, 1), 2).Value = b
        .Range("A:A").EntireColumn.AutoFit
    End With
    
End Sub

 

[alansidman]

An alternative solution is to unpivot your data with Power Query

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Filtered Rows" = Table.SelectRows(Source, each ([S] <> "S")),
    #"Unpivoted Other Columns" = Table.UnpivotOtherColumns(#"Filtered Rows", {"Column1"}, "Attribute", "Value"),
    #"Merged Columns" = Table.CombineColumns(#"Unpivoted Other Columns",{"Column1", "Attribute"},Combiner.CombineTextByDelimiter("-", QuoteStyle.None),"SKU"),
    #"Renamed Columns" = Table.RenameColumns(#"Merged Columns",{{"Value", "QTY"}}),
    #"Filtered Rows1" = Table.SelectRows(#"Renamed Columns", each ([QTY] = 1))
in
    #"Filtered Rows1"

 

[decent_boy]

Thank you so much both of you