Transpose Data from column to Row

hardeep.kanwar

hardeep.kanwar

Well-known Member
Joined
Aug 13, 2008
Messages
688
Dear Experts

I need to transpose the data from column to Row (Below is the example of my data)

Format is not always same some have 7 rows and some have 8 rows, After every data, there is Blank row,for me main problem his Amount (Column B), I need to insert the new Column After EFT INCOMING and put the amount

Can you please help on this

Data in sheet 1

EFT INCOMING4,312.00
SAA230887163 NEFT IN UTR
CITIN16713406945 FROM MS
SHEKHAR VEHICLES
SAA230887163TXN REF NO
URGENTMS SHEKHAR VEHICLES
TRN REF NO:D01ZOAC163331S0R
EFT INCOMING4,312.00
KKBKH16333640302 NEFT IN
UTR CITIN16713400139
FROM SATYA SERVICES
KKBKH16333640302TXN REF
NO Payment
TRN REF NO:D01ZOAC163331S1s
EFT INCOMING8,625.00
AXISP16333234589 NEFT IN
UTR CITIN16713255608
FROM K L GUPTA AND CO
AUTOMOBI
AXISP16333234589TXN REF
NO 01281116364601
TRN REF NO:D01ZOAC163330sKC

<tbody>
</tbody>


Expected result In Sheet 2

<!-- Please do not remove this header -->


EFT INCOMING4,312.00AXISP16333234589 NEFT INUTR CITIN16713255608FROM K L GUPTA AND COAUTOMOBIAXISP16333234589TXN REFNO 01281116364601TRN REF NO:D01ZOAC163330sKC
EFT INCOMING4,312.00SAA230887163 NEFT IN UTRCITIN16713406945 FROM MSSHEKHAR VEHICLESSAA230887163TXN REF NOURGENTMS SHEKHAR VEHICLESTRN REF NO:D01ZOAC163331S0R
EFT INCOMING8,625.00KKBKH16333640302 NEFT INUTR CITIN16713400139FROM SATYA SERVICESKKBKH16333640302TXN REFNO PaymentTRN REF NO:D01ZOAC163331S1s

<tbody>
</tbody>
 

Excel Facts

Select a hidden cell
Somehide hide payroll data in column G? Press F5. Type G1. Enter. Look in formula bar while you arrow down through G.
Sort by date Sort by votes
R

RCBricker

Well-known Member
Joined
Feb 4, 2003
Messages
1,560
hardeep.kanwar said:
Dear Experts

I need to transpose the data from column to Row (Below is the example of my data)

Format is not always same some have 7 rows and some have 8 rows, After every data, there is Blank row,for me main problem his Amount (Column B), I need to insert the new Column After EFT INCOMING and put the amount

Can you please help on this

Data in sheet 1

EFT INCOMING4,312.00
SAA230887163 NEFT IN UTR
CITIN16713406945 FROM MS
SHEKHAR VEHICLES
SAA230887163TXN REF NO
URGENTMS SHEKHAR VEHICLES
TRN REF NO:D01ZOAC163331S0R
EFT INCOMING4,312.00
KKBKH16333640302 NEFT IN
UTR CITIN16713400139
FROM SATYA SERVICES
KKBKH16333640302TXN REF
NO Payment
TRN REF NO:D01ZOAC163331S1s
EFT INCOMING8,625.00
AXISP16333234589 NEFT IN
UTR CITIN16713255608
FROM K L GUPTA AND CO
AUTOMOBI
AXISP16333234589TXN REF
NO 01281116364601
TRN REF NO:D01ZOAC163330sKC

<tbody>
</tbody>


Expected result In Sheet 2

<!-- Please do not remove this header -->


EFT INCOMING4,312.00AXISP16333234589 NEFT INUTR CITIN16713255608FROM K L GUPTA AND COAUTOMOBIAXISP16333234589TXN REFNO 01281116364601TRN REF NO:D01ZOAC163330sKC
EFT INCOMING4,312.00SAA230887163 NEFT IN UTRCITIN16713406945 FROM MSSHEKHAR VEHICLESSAA230887163TXN REF NOURGENTMS SHEKHAR VEHICLESTRN REF NO:D01ZOAC163331S0R
EFT INCOMING8,625.00KKBKH16333640302 NEFT INUTR CITIN16713400139FROM SATYA SERVICESKKBKH16333640302TXN REFNO PaymentTRN REF NO:D01ZOAC163331S1s

<tbody>
</tbody>
Click to expand...

try this

Code: 
Sub Hardeep()

Dim lngROW As Long, lngCOL As Long, lngROW2 As Long
Dim rng As Range, cell As Range, rngCOPY As Range
Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Sheets("Hardeep1")
    Set ws2 = Sheets("Hardeep2")
    ws1.Select
    With ws1
        lngROW = ws1.cells.Find(What:="*", _
                after:=ws1.cells(1), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
        lngCOL = ws1.cells.Find(What:="*", _
                after:=ws1.cells(1), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Column
        Set rng = ws1.Range(ws1.cells(1, 1), ws1.cells(lngROW, 1))
        For Each cell In rng
            ws1.Select
            If cell.Value = "EFT INCOMING" Then
                Application.CutCopyMode = False
                Set rngCOPY = ws1.Range(ws1.cells(cell.Row, 1), _
                    ws1.cells(cell.Row, 2))
                rngCOPY.Copy
                ws2.Select
                With ws2
                    lngROW2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
                    If lngROW2 = 1 And ws2.cells(1, 1) = "" Then
                        ws2.cells(lngROW2, 1).PasteSpecial xlPasteAll
                    Else
                        lngROW2 = lngROW2 + 1
                        ws2.cells(lngROW2, 1).PasteSpecial xlPasteAll
                    End If
                End With
                lngROW = ws1.cells(cell.Row, 1).End(xlDown).Row
                Set rngCOPY = ws1.Range(ws1.cells(cell.Row + 1, 1), _
                    ws1.cells(lngROW, 1))
                rngCOPY.Copy
                
                ws2.cells(lngROW2, 3).PasteSpecial xlPasteAll, , , Transpose:=True
            End If
        Next cell
    End With
End Sub
 
Upvote 0
hardeep.kanwar

hardeep.kanwar

Well-known Member
Joined
Aug 13, 2008
Messages
688
Thanks a ton sir,

Can you modify this code, now i have one more column of Date also


Excel 2010
ABC
416-Nov-16EFT INCOMING8,625.00
10-29


Expected




<tbody>
</tbody>

Excel 2010
ABCDEFGH
116-Nov-16EFT INCOMING8,625.00IDIBH16321204911 NEFT INUTR CITIN16710131225FROM MANI NAGAPPA MOTORSLTD IDIBH16321204911TXNREF NO
Hardeep2
 
Upvote 0
hardeep.kanwar

hardeep.kanwar

Well-known Member
Joined
Aug 13, 2008
Messages
688
Excel 2010
ABC
116-Nov-16EFT INCOMING8,625.00
2IDIBH16321204911 NEFT IN
3UTR CITIN16710131225
4FROM MANI NAGAPPA MOTORS
5LTD IDIBH16321204911TXN
6REF NO
7
816-Nov-16EFT INCOMING8,625.00
9IDIBH16321205523 NEFT IN
10UTR CITIN16710132341
11FROM MANI NAGGAPPA
12
1317-Nov-16EFT INCOMING4,312.50
141082612214 NEFT IN UTR
15CITIN16710563027 FROM
16YASH AUTOMOBILES
171082612214TXN REF NO
18JOYRIDE PAYMENT
19TRN REF NO:D01ZOAC163220naY

<colgroup><col style="width: 25pxpx"><col><col><col></colgroup><thead>
</thead><tbody>
</tbody>
Sheet1​
Expected


Excel 2010
ABCDEFGH
116-Nov-16EFT INCOMING8,625.00IDIBH16321204911 NEFT INUTR CITIN16710131225FROM MANI NAGAPPA MOTORSLTD IDIBH16321204911TXNREF NO
Hardeep2
 
Last edited:
Upvote 0
R

RCBricker

Well-known Member
Joined
Feb 4, 2003
Messages
1,560
this should do it.

Code: 
Sub Hardeep()

Dim lngROW As Long, lngCOL As Long, lngROW2 As Long
Dim rng As Range, cell As Range, rngCOPY As Range
Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Sheets("Hardeep1")
    Set ws2 = Sheets("Hardeep2")
    ws1.Select
    With ws1
        lngROW = ws1.cells.Find(What:="*", _
                after:=ws1.cells(1), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
        lngCOL = ws1.cells.Find(What:="*", _
                after:=ws1.cells(1), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Column
        Set rng = ws1.Range(ws1.cells(1, 2), ws1.cells(lngROW, 2))
        For Each cell In rng
            ws1.Select
            If cell.Value = "EFT INCOMING" Then
                Application.CutCopyMode = False
                Set rngCOPY = ws1.Range(ws1.cells(cell.Row, 1), _
                    ws1.cells(cell.Row, 3))
                rngCOPY.Copy
                ws2.Select
                With ws2
                    lngROW2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
                    If lngROW2 = 1 And ws2.cells(1, 1) = "" Then
                        ws2.cells(lngROW2, 1).PasteSpecial xlPasteAll
                    Else
                        lngROW2 = lngROW2 + 1
                        ws2.cells(lngROW2, 1).PasteSpecial xlPasteAll
                    End If
                End With
                lngROW = ws1.cells(cell.Row, 1).End(xlDown).Row
                Set rngCOPY = ws1.Range(ws1.cells(cell.Row + 1, 1), _
                    ws1.cells(lngROW, 1))
                rngCOPY.Copy
                
                ws2.cells(lngROW2, 4).PasteSpecial xlPasteAll, , , Transpose:=True
            End If
        Next cell
    End With
End Sub
 
Upvote 0
hardeep.kanwar

hardeep.kanwar

Well-known Member
Joined
Aug 13, 2008
Messages
688
I got Run Time Error 400

And Result is


Excel 2010
ABCDEFGHIJ
116-Nov-16EFT INCOMING8,625.0016-Nov-16
216-Nov-16EFT INCOMING8,625.0017-Nov-16
317-Nov-16EFT INCOMING4,312.50
Hardeep2
 
Upvote 0
R

RCBricker

Well-known Member
Joined
Feb 4, 2003
Messages
1,560
forgot to change a range

Code: 
Sub Hardeep()

Dim lngROW As Long, lngCOL As Long, lngROW2 As Long
Dim rng As Range, cell As Range, rngCOPY As Range
Dim ws1 As Worksheet, ws2 As Worksheet

    Set ws1 = Sheets("Hardeep1")
    Set ws2 = Sheets("Hardeep2")
    ws1.Select
    With ws1
        lngROW = ws1.cells.Find(What:="*", _
                after:=ws1.cells(1), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
        lngCOL = ws1.cells.Find(What:="*", _
                after:=ws1.cells(1), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Column
        Set rng = ws1.Range(ws1.cells(1, 2), ws1.cells(lngROW, 2))
        For Each cell In rng
            ws1.Select
            If cell.Value = "EFT INCOMING" Then
                Application.CutCopyMode = False
                Set rngCOPY = ws1.Range(ws1.cells(cell.Row, 1), _
                    ws1.cells(cell.Row, 3))
                rngCOPY.Copy
                ws2.Select
                With ws2
                    lngROW2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
                    If lngROW2 = 1 And ws2.cells(1, 1) = "" Then
                        ws2.cells(lngROW2, 1).PasteSpecial xlPasteAll
                    Else
                        lngROW2 = lngROW2 + 1
                        ws2.cells(lngROW2, 1).PasteSpecial xlPasteAll
                    End If
                End With
                lngROW = ws1.cells(cell.Row, 2).End(xlDown).Row
                Set rngCOPY = ws1.Range(ws1.cells(cell.Row + 1, 2), _
                    ws1.cells(lngROW, 2))
                rngCOPY.Copy
                
                ws2.cells(lngROW2, 4).PasteSpecial xlPasteAll, , , Transpose:=True
            End If
        Next cell
    End With
End Sub
 
Upvote 0
hardeep.kanwar

hardeep.kanwar

Well-known Member
Joined
Aug 13, 2008
Messages
688
Thanks a lot Sir (y)

One more thing right now i have 6000 data and in future i will go to more than 1 Lac.

Can you make this code Faster
 
Upvote 0
R

RCBricker

Well-known Member
Joined
Feb 4, 2003
Messages
1,560
here is the old code and new faster code with a msgbox with the times.

Code: 
Sub HardeepNEW()

Dim lngROW As Long, lngCOL As Long, lngROW2 As Long, lngCNT As Long
Dim rng As Range, cell As Range, rngCOPY As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim arrCOPY As Variant, i As Variant

    i = Timer
    With Application
        .ScreenUpdating = False
    End With
    Set ws1 = Sheets("Hardeep1")
    Set ws2 = Sheets("Hardeep2")
    ws1.Select
    With ws1
        lngROW = ws1.Range("B" & ws1.Rows.Count).End(xlUp).Row
        lngCOL = ws1.cells(1, .Columns.Count).End(xlToLeft).Column
        Set rng = ws1.Range(ws1.cells(1, 2), ws1.cells(lngROW, 2))
        For Each cell In rng
            If cell.Value = "EFT INCOMING" Then
                Application.CutCopyMode = False
                Set rngCOPY = ws1.Range(ws1.cells(cell.Row, 1), _
                    ws1.cells(cell.Row, 3))
                rngCOPY.Copy
                With ws2
                    If ws2.cells(1, 1) = "" Then
                        lngROW2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
                    Else
                        lngROW2 = ws2.Range("A" & ws2.Rows.Count). _
                            End(xlUp).Offset(1).Row
                    End If
                    ws2.cells(lngROW2, 1).PasteSpecial xlPasteAll
                End With
                lngROW = ws1.cells(cell.Row, 2).End(xlDown).Row
                Set rngCOPY = ws1.Range(ws1.cells(cell.Row + 1, 2), _
                    ws1.cells(lngROW, 2))
                arrCOPY = rngCOPY
                ws2.cells(lngROW2, 4).Resize(, UBound(arrCOPY)) = arrCOPY
            End If
        Next cell
    End With
    With Application
        .ScreenUpdating = True
    End With
    MsgBox Timer - i
End Sub
Sub HardeepOLD()

Dim lngROW As Long, lngCOL As Long, lngROW2 As Long
Dim rng As Range, cell As Range, rngCOPY As Range
Dim ws1 As Worksheet, ws2 As Worksheet
Dim i As Variant
i = Timer

    Set ws1 = Sheets("Hardeep1")
    Set ws2 = Sheets("Hardeep2")
    ws1.Select
    With ws1
        lngROW = ws1.cells.Find(What:="*", _
                after:=ws1.cells(1), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Row
        lngCOL = ws1.cells.Find(What:="*", _
                after:=ws1.cells(1), _
                LookAt:=xlPart, _
                LookIn:=xlFormulas, _
                SearchOrder:=xlByColumns, _
                SearchDirection:=xlPrevious, _
                MatchCase:=False).Column
        Set rng = ws1.Range(ws1.cells(1, 2), ws1.cells(lngROW, 2))
        For Each cell In rng
            ws1.Select
            If cell.Value = "EFT INCOMING" Then
                Application.CutCopyMode = False
                Set rngCOPY = ws1.Range(ws1.cells(cell.Row, 1), _
                    ws1.cells(cell.Row, 3))
                rngCOPY.Copy
                ws2.Select
                With ws2
                    lngROW2 = ws2.Range("A" & ws2.Rows.Count).End(xlUp).Row
                    If lngROW2 = 1 And ws2.cells(1, 1) = "" Then
                        ws2.cells(lngROW2, 1).PasteSpecial xlPasteAll
                    Else
                        lngROW2 = lngROW2 + 1
                        ws2.cells(lngROW2, 1).PasteSpecial xlPasteAll
                    End If
                End With
                lngROW = ws1.cells(cell.Row, 2).End(xlDown).Row
                Set rngCOPY = ws1.Range(ws1.cells(cell.Row + 1, 2), _
                    ws1.cells(lngROW, 2))
                rngCOPY.Copy
                
                ws2.cells(lngROW2, 4).PasteSpecial xlPasteAll, , , Transpose:=True
            End If
        Next cell
    End With
MsgBox Timer - i
End Sub
 
Upvote 0
You must log in or register to reply here.

Forum statistics

Threads
1,191,416
Messages
5,986,434
Members
440,030
Latest member
ninomato

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top