Converting column data to rows urgent

[exceluser9]

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]

Try:

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

 

[exceluser9]

Hi

It's working fine, could we add a blank row after each number in sheet 1?

 

[mumps]

Try:

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

 

[exceluser9]

Hi,

Thank you for updated code.

In sheet 1 data is getting pasted in from row 1, can it be pasted from row A2?

 

[mumps]

Replace this line of code:

desWS.Rows("1:2").Delete

with this one:

desWS.Rows("1:1").Delete