Help, needs macro to transpose the original to the new format as shown below

[pipemar]

Excel 2012
	A	B	C	D	E	F	G	H	I
2	ORIGINAL FORMAT
3	Item #	TNS	DESC	CN	STORAGE	FIELD	OFFICE	*******	DECK
4	1	15	SODA	B	50			15
5	2	99	VINEGAR	B	80			2
6	3	15	SOY SAUCE	B			60
7	4	99	BLACK PEPPER	B			80
8	5	15	SUGAR	B			25
9
10
11
12	NEW FORMAT
13	SN	WBS	Desc	CN	Desc1	Qty
14	1	15	SODA	B	STORAGE	50
15	1	15	SODA	B	*******	15
16	2	99	VINEGAR	B	STORAGE	80
17	2	99	VINEGAR	B	*******	2
18	3	15	SOY SAUCE	B	OFFICE	60
19	4	99	BLACK PEPPER	B	OFFICE	80
20	5	15	SUGAR	B	OFFICE	25
Sheet1

Thanks in advance

 

[RickXL]

Hi,

I have made some assumptions. For instance, I have used two worksheets that start in row 1.
Note: Sheet2 is cleared when the macro runs.

Sub myTranspose()

    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Dim iRow As Long
    Dim jCol As Long
    Dim kRow As Long
    
    kRow = 2
    
    With ws2
        .Cells.Clear
        .Range("A1:F1") = Array("SN", "WBS", "Desc", "CN", "Desc1", "Qty")
    End With
    
    With ws1
        For iRow = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
            For jCol = 5 To 9
                If .Cells(iRow, jCol).Value <> "" Then
                    ws2.Cells(kRow, 1) = .Cells(iRow, 1).Value
                    ws2.Cells(kRow, 2) = .Cells(iRow, 2).Value
                    ws2.Cells(kRow, 3) = .Cells(iRow, 3).Value
                    ws2.Cells(kRow, 4) = .Cells(iRow, 4).Value
                    ws2.Cells(kRow, 5) = .Cells(1, jCol).Value
                    ws2.Cells(kRow, 6) = .Cells(iRow, jCol).Value
                    kRow = kRow + 1
                End If
            Next
        Next
    End With

End Sub

 

[pipemar]

RickXL

Thank you very much. But, is it possible that the result will be from row 13 to row 20 only of the new format?

Pipemar

 

[RickXL]

Hi,

I made it start at row 13 now.

However, I don't know whether you intend to use just one worksheet as in your example or whether you really need two. This affects how the clear works.

Anyway, try this:

Sub myTranspose()

    Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    Dim iRow As Long
    Dim jCol As Long
    Dim kRow As Long
    Dim LastRow As Long
    
    kRow = 13
    
    
    With ws2
        .Rows(kRow & ":" & Sheet1.Rows.Count).Clear
        LastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
        .Range(.Cells(kRow, 1), .Cells(kRow, 6)) = Array("SN", "WBS", "Desc", "CN", "Desc1", "Qty")
        kRow = kRow + 1
    End With
    
    
    With ws1
        For iRow = 2 To LastRow
            For jCol = 5 To 9
                If .Cells(iRow, jCol).Value <> "" Then
                    ws2.Cells(kRow, 1) = .Cells(iRow, 1).Value
                    ws2.Cells(kRow, 2) = .Cells(iRow, 2).Value
                    ws2.Cells(kRow, 3) = .Cells(iRow, 3).Value
                    ws2.Cells(kRow, 4) = .Cells(iRow, 4).Value
                    ws2.Cells(kRow, 5) = .Cells(1, jCol).Value
                    ws2.Cells(kRow, 6) = .Cells(iRow, jCol).Value
                    kRow = kRow + 1
                End If
            Next
        Next
    End With

End Sub

 

[hiker95]

pipemar,

1. What version of Excel and Windows are you using?

2. Are you using a PC or a Mac?

Here is another macro solution for you to consider that uses two arrays in memory.

The following macro is based on your raw data structure, and, where the results should start.

Sample raw data in Sheet1, and, results (you can change the raw data worksheet name in the macro):

Excel 2007
	A	B	C	D	E	F	G	H	I
1
2
3	Item #	TNS	DESC	CN	STORAGE	FIELD	OFFICE	*******	DECK
4	1	15	SODA	B	50			15
5	2	99	VINEGAR	B	80			2
6	3	15	SOY SAUCE	B			60
7	4	99	BLACK PEPPER	B			80
8	5	15	SUGAR	B			25
9
10
11
12
13	SN	WBS	Desc	CN	Desc1	Qty
14	1	15	SODA	B	STORAGE	50
15	1	15	SODA	B	*******	15
16	2	99	VINEGAR	B	STORAGE	80
17	2	99	VINEGAR	B	*******	2
18	3	15	SOY SAUCE	B	OFFICE	60
19	4	99	BLACK PEPPER	B	OFFICE	80
20	5	15	SUGAR	B	OFFICE	25
21
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ReorgData()
' hiker95, 03/29/2015, ME845010
Dim a As Variant, o As Variant
Dim i As Long, j As Long
Dim lr As Long, lr2 As Long, n As Long, c As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")   ''<-- you can change the raw data sheetname here
  lr = .Cells(3, 1).End(xlDown).Row
  lr2 = .Cells(Rows.Count, 1).End(xlUp).Row
  If lr2 > lr Then .Range("A" & lr + 1 & ":F" & lr2).ClearContents
  a = .Range("A3:I" & lr)
  n = Application.Count(.Range("E4:I" & lr))
  ReDim o(1 To n, 1 To 6)
  .Range("A13").Resize(, 6).Value = Array("SN", "WBS", "Desc", "CN", "Desc1", "Qty")
  For i = 2 To UBound(a, 1)
    For c = 5 To UBound(a, 2)
      If a(i, c) <> "" Then
        j = j + 1: o(j, 1) = a(i, 1): o(j, 2) = a(i, 2)
        o(j, 3) = a(i, 3): o(j, 4) = a(i, 4)
        o(j, 5) = a(1, c): o(j, 6) = a(i, c)
      End If
    Next c
  Next i
  .Range("A14").Resize(UBound(o, 1), UBound(o, 2)) = o
  .Columns("A:I").AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ReorgData macro.

 

[pipemar]

Hiker95,

Thanks for the help. RickXL's first macro is correct already. It's just I have some data that I need to delete prior to running the macro.

Thanks again.
Pipemar

 

[hiker95]

pipemar,

Thanks for the feedback.

You are welcome.

Did you even try my macro?

 

[pipemar]

hiker95,

Yes I did but for some reason, It's not giving me the new format.

Regards,
pipemar