Excel VBA code to represent data from row wise to column wise

Question

Hello expets,

It is working but want to show the report in next sheet with column headers and main raw data should same as their original state (place).

Just like

In sheet1

category    Subcategory

A                   aa

B                    bb

C                    cc

A                     dd

B                      ee

C                      ff

A                       gg

report should come in next sheet

in sheet2

category      subcategory

A                    aa                        dd               gg

B                     bb                       ee

C                      cc                        ff

Request to experts , Kindly share your valuable times.

Thank you in advance

Regards,

Shiv

Answer 1

Hi,

1. data in source sht (sheet1)

2. results in sheet2

xxxxxxxxxxxx

vba macro

Sub Convert_Sort_Transpose()

'Sep 25, 2015

Dim ws As Worksheet, ws1 As Worksheet

Set ws = Sheets**("Sheet1") '<< source sheet name, change**

Set ws1 = Sheets**("Sheet2") '<< target sheet name, change**

Application.ScreenUpdating = False

ws1.UsedRange.ClearContents

Dim r As Long, r1 As Long, i As Long, c As Long

r = ws.Cells(Rows.Count, 1).End(xlUp).Row

ws.Range("A1:A" & r).Copy: ws1.Range("A1").PasteSpecial xlPasteValues

Application.CutCopyMode = False

ws1.Range("A1:A" & r).RemoveDuplicates Columns:=1, Header:=xlYes

r1 = ws1.Cells(Rows.Count, 1).End(xlUp).Row

ws1.Range("A1:A" & r1).Sort Key1:=ws1.[A1], Order1:=xlAscending, Header:=xlYes, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal

ws1.[B1].Value = ws.[B1].Value

ws.AutoFilterMode = False

For i = 2 To r1

ws.Range("A1:A" & r).AutoFilter field:=1, Criteria1:=ws1.Cells(i, 1).Value

ws.Range("b2:b" & r).SpecialCells(xlCellTypeVisible).Copy

ws1.Cells(i, 2).PasteSpecial xlPasteValues, Transpose:=True

c = ws1.Cells(i, Columns.Count).End(xlToLeft).Column

If c = 2 Then GoTo nnext

ws1.Cells(i, 2).Resize(, c - 1).Sort Key1:=ws1.Cells(i, 2), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight, DataOption1:=xlSortNormal

nnext:

Next

ws.AutoFilterMode = False

With ws1.UsedRange

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.Columns.AutoFit

End With

[A1].Select

Application.ScreenUpdating = True

End Sub

Answer 2

1. Save your file as .xlsm
2. ALT+F11
3. Locate your Workbook name in Project Explorer Window
4. Right click on your workbook name > Insert > Module 
5. Copy paste the below code in this
6. ALT+F8 to display Macro Window
7. Run your Macro from here

'***********************************************************

Sub RowToCol()

    Dim Rng As Range, Cell As Range

    Dim x As Long, RowNum As Long

    Dim Ws1 As Worksheet, Ws2 As Worksheet

    On Error Resume Next

    Set Ws1 = Sheet1

    Set Ws2 = Sheet2

    Set Rng = Ws1.Range("A2:A" & Ws1.Range("A" & Rows.Count).End(xlUp).Row)

    Application.ScreenUpdating = False

    Ws2.Range("A1") = Ws1.Range("A1")

    Ws2.Range("B1") = Ws1.Range("B1")

    For Each Cell In Rng

        x = Application.WorksheetFunction.CountIf(Ws2.Columns("A"), Cell)

        If x = 0 Then

            RowNum = Ws2.Range("A" & Rows.Count).End(xlUp).Row + 1

            Ws2.Cells(RowNum, 1) = Cell

            Ws2.Cells(RowNum, 1).Offset(0, 1) = Cell.Offset(0, 1)

            Else

            RowNum = Application.WorksheetFunction.Match(Cell, Ws2.Columns("A"), 0)

            x = Application.WorksheetFunction.CountIf(Ws1.Range("A2:" & Cell.Address(0, 0)), Cell)

            Ws2.Cells(RowNum, 1).Offset(0, x) = Cell.Offset(0, 1)

            If Ws2.Cells(1, 1 + x) = "" Then

                Ws2.Cells(1, 1 + x) = Ws1.Range("B1")

            End If

        End If

     Next Cell

ErrorHandler:

    Application.ScreenUpdating = True

End Sub