Converting column data to rows urgent

exceluser9

Active Member
Hi Team.

I need a VBA code to transpose.column data into rows. Below is example.

Sheet 2

Column A Column B
Sl no. Data
17957 Missing number
17957 Missing Data
17957 Additional data required
17957 Address not available
17957 DOB Missing
17957 Require account details

In sheet when I input number 17957 it should give me all 6 row data in Column B, Column C, Column D, Column E, Column F, Column G

Above is just an examples, there is no data limit, macro should run until the data is present and give results. No all sl no will have 6 row of data. It could be 1/2/3/4/5/6. Sl no will be keep on changing, it can be 2 digit or greater than that

Sheet 1

Column A
17957

Thanks
 

mumps

Well-known Member
Try:
Code:
Sub Transpsoedata()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, key As Variant, desWS As Worksheet
    Set desWS = Sheets("Sheet1")
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In Range("A2", Range("A" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each key In RngList
        With Cells(1, 1).CurrentRegion
            .AutoFilter 1, key
            Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0) = key
                .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 0).PasteSpecial Transpose:=True
            End With
        End With
    Next key
    Range("A1").AutoFilter
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
 

mumps

Well-known Member
Try:
Code:
Sub TransposeData()
    Application.ScreenUpdating = False
    Dim Rng As Range, RngList As Object, key As Variant, desWS As Worksheet
    Set desWS = Sheets("Sheet1")
    Set RngList = CreateObject("Scripting.Dictionary")
    For Each Rng In Range("A2", Range("A" & Rows.Count).End(xlUp))
        If Not RngList.Exists(Rng.Value) Then
            RngList.Add Rng.Value, Nothing
        End If
    Next
    For Each key In RngList
        With Cells(1, 1).CurrentRegion
            .AutoFilter 1, key
            Range("B2", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
            With desWS
                .Cells(.Rows.Count, "A").End(xlUp).Offset(2, 0) = key
                .Cells(.Rows.Count, "B").End(xlUp).Offset(2, 0).PasteSpecial Transpose:=True
            End With
        End With
    Next key
    Range("A1").AutoFilter
    desWS.Rows("1:2").Delete
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub
 

mumps

Well-known Member
Replace this line of code:
Code:
desWS.Rows("1:2").Delete
with this one:
Code:
desWS.Rows("1:1").Delete
 

Some videos you may like

This Week's Hot Topics

Top