Transpose Multiple Columns to Rows by Fixing the value from 1 column and excluding Blanks

[avid.excel.user]

Hi All

Need your help in transposing values from columns to rows.

For example the data is as follows:
Name | Number | Address 1 | Address 2 | Pincode
Mr. A | 1 | Block A | East Street | 123 |
Mr. B | 2 | Block B | West Street | |

Needs to be converted to :
Name | Details
Mr. A | 1
Mr. A | Block A
Mr. A | East Street
Mr. A | 123
Mr. B | 2
Mr. B | Block B
Mr. B | West Street

Please note : Columns may have a Blank Value which need not be transposed

There will be 1000 of such rows and 10 of such columns.

Please help with a formula or a VB code to run this for desired outcome.

Thank you

 

[avid.excel.user]

Please help !

 

[kevin9999]

I'm not sure where you want the data to be transposed to, but here's a method that puts the transposed data from Sheet1 to Sheet2 - you'll need to tweak it to suit. Assumes your data starts in cell A2 on sheet 1 and that row 1 is a header row. Try it out on a copy of your data.

EDITED

Option Explicit
Sub Transpose_Stuff()
    Dim a, b, i As Long, j As Long, k As Long
    
    a = Sheet1.Range("A1").CurrentRegion.Offset(1)
    ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 2)
    k = 1
    For i = 1 To UBound(a, 1)
        For j = 2 To UBound(a, 2)
            b(k, 1) = a(i, 1)
            If a(i, j) <> "" Then
                b(k, 2) = a(i, j)
                k = k + 1
            End If
        Next j
    Next i
    
    With Sheet2
        .Range("A1").Resize(, 2).Value = Array("Name", "Details")
        .Range("A2").Resize(UBound(b, 1), 2).Value = b
    End With
End Sub

 

[mohadin]

HI

a Blank Value which need not be transposed

May try

Sub test()
Dim a, x
Dim i&, ii&, lr&
 a = Cells(1).CurrentRegion.Offset(1)
 With CreateObject("scripting.dictionary")
 For i = 1 To UBound(a) - 1
        For ii = 2 To UBound(a, 2)
            x = IIf(x = "", a(i, ii), IIf((a(i, ii) = "" Or a(i, ii) = " "), x, x & "|" & a(i, ii)))
         Next
.Add a(i, 1), Split(x, "|")
x = ""
Next
For i = 0 To .Count - 1
lr = Cells(Rows.Count, 11).End(xlUp).Row + 1
Cells(lr, 11).Resize(UBound(.Items()(i)) + 1) = .keys()(i)
Cells(lr, 12).Resize(UBound(.Items()(i)) + 1) = Application.Transpose(.Items()(i))
Next
End With
End Sub

 

[Herakles]

Another approach.

Just change the worksheet names in these two lines.

Set WsSource = Worksheets("TransposeSource")
Set WsTarget = Worksheets("TransposeTarget")

The code assumes that the data starts in range A1.

Public Sub subTransposeMultipleColumnsToRows()
Dim WsSource As Worksheet
Dim WsTarget As Worksheet
Dim intColumns As Integer

    Set WsSource = Worksheets("TransposeSource")
    Set WsTarget = Worksheets("TransposeTarget")
    
    WsTarget.Cells.ClearContents
    
    intColumns = WsSource.Range("A1").CurrentRegion.Columns.Count
    
    WsTarget.Range("A1:B1").Value = Array("Name", "Details")
                       
    For Each Rng In WsSource.Range("A2:A" & WsSource.Range("A1").End(xlDown).Row).Cells
        
        WsTarget.Range("B" & WsTarget.Cells(Rows.Count, 2).End(xlUp).Row + 1).Formula2 = _
            "=TRANSPOSE(FILTER(" & WsSource.Name & "!" & Rng.Offset(0, 1).Resize(1, intColumns).Address & "," & _
            WsSource.Name & "!" & Rng.Offset(0, 1).Resize(1, intColumns).Address & "<>""""))"
           
        With WsTarget.Range("A1").CurrentRegion.Columns(1)
            .SpecialCells(xlCellTypeBlanks).Value = Rng.Value
        End With
        
    Next Rng
            
End Sub

 

[avid.excel.user]

I'm not sure where you want the data to be transposed to, but here's a method that puts the transposed data from Sheet1 to Sheet2 - you'll need to tweak it to suit. Assumes your data starts in cell A2 on sheet 1 and that row 1 is a header row. Try it out on a copy of your data.

EDITED

Option Explicit
Sub Transpose_Stuff()
    Dim a, b, i As Long, j As Long, k As Long
   
    a = Sheet1.Range("A1").CurrentRegion.Offset(1)
    ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 2)
    k = 1
    For i = 1 To UBound(a, 1)
        For j = 2 To UBound(a, 2)
            b(k, 1) = a(i, 1)
            If a(i, j) <> "" Then
                b(k, 2) = a(i, j)
                k = k + 1
            End If
        Next j
    Next i
   
    With Sheet2
        .Range("A1").Resize(, 2).Value = Array("Name", "Details")
        .Range("A2").Resize(UBound(b, 1), 2).Value = b
    End With
End Sub

This Works Amazing ! Thank you so much

 

[kevin9999]

This Works Amazing ! Thank you so much

Happy to help & thanks for the feedback - although I'm understandably curious as to why you marked a different answer as the solution?