transpose data from rows to single column

Question

i am trying this formula to transpose given data but it is also taking blank cells how can i ignore them while transposing

result wanted worksheet ss this is worksheet ss i want to transpose and paste data in column A

B01MU6O7H7                              
B07XB9NN9B  B07261QWHY  B071W4GMN3  B07X8BPD82  B07X8BNJZQ  B07X8BNBJH          
B071JLW811  B071WK2YKV  B071WK2QHN  B072JTCJF8  B071G11SR7  B072QCCV2Q  B0743JHJBH      
B078GVQFB5  B078GQ9V6W  B078GTFHMY  B078GR4H15  B079KFH765  B078GTXD9N  B078GPVH73      
B078G6515S                              
B07T891H6J  B07T9DFRSM  B07T893RJM  B07TFHJ1XR  B07T9DGB2V  B07TFHJ6ZX  B07TBFC852      
B01N2WJ0OR  B01MQYNB3M  B06Y3Z65C5  B01MQZU45F                  
B076YFYD19  B076YF2ZNY  B074Z9ZY1S  B076XZ9WZV  B079KSDHSQ  B079KQJHZD  B074ZK64V3      
B07XJYL5Y2  B07XL3Y773                          
B07FCQTZ5X  B06XZ7Z93Z                          
B07MN7YHLM  B07M9HGJWP  B07MK98FJ5  B07M9HGN5D  B01NCVGDIC  B01N4NBSV9  B07MN8YKFQ  B074MZ93JP  B01N7RH9ZB
B07TKXWLFZ  B071CMQ6N2  B07VG1L2M5                      
B01B0SR1IY                              
B07GZFZQ6H  B07GZHSBRT  B07GZHG64J  B07GZDQ7QW                  
B07WLX685Q  B07WF3MQPB  B07WD3CHDW  B07W9KXP9Q  B07WG787XB  B07WD3BCDR          
B07J2K4WCV  B07J2MGH5W  B07J2L9MZS  B07J2LF71R                  
B07F9VP9QM  B07F9ZLCZW  B07FB1XZGL                      

---

Sub ConvertRangeToColumn()
Dim Range1 As Range, Range2 As Range, Rng As Range
Dim rowIndex As Integer
xTitleId = "KutoolsforExcel"
Set Range1 = Application.Selection
Set Range1 = Application.InputBox("Source Ranges:", xTitleId, Range1.Address, Type:=8)
Set Range2 = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)
rowIndex = 0
Application.ScreenUpdating = False
For Each Rng In Range1.Rows
Rng.Copy
Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, transpose:=True
rowIndex = rowIndex + Rng.Columns.Count
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Answer 1

If you have Excel 2010+, you can use Power Query (aka Get & Transform in 2016+).

• Select a cell in the table
• In 2016, you would navigate to the Data Tab; then select Get & Transfrom from Table/Range
• In the PQ Editor that opens:
  • Select All the columns
  • From the Transform tab, select Unpivot Columns
• Delete the Attribute column
• Close and Load

M-Code: *generated by PQ**

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Changed Type" = Table.TransformColumnTypes(Source,{{"Column1", type text}, {"Column2", type text}, {"Column3", type text}, {"Column4", type text}, {"Column5", type text}, {"Column6", type text}, {"Column7", type text}, {"Column8", type text}, {"Column9", type text}}),
    #"Unpivoted Columns" = Table.UnpivotOtherColumns(#"Changed Type", {}, "Attribute", "Value"),
    #"Removed Columns" = Table.RemoveColumns(#"Unpivoted Columns",{"Attribute"})
in
    #"Removed Columns"

Results

Answer 2

Try something like this:

Loop the cells in your range, if not blank assign value to an array and then write the array from the destination set.

Sub TransposeMultiColumnDataToOneColumn()
Dim myArray As Variant
Dim SourceRange As Range, DestinationRange  As Range

Set SourceRange = Application.InputBox("Source Ranges:", xTitleId, Type:=8)
Set DestinationRange = Application.InputBox("Convert to (single cell):", xTitleId, Type:=8)

Dim ArrayCounter As Long
ReDim myArray(1 To SourceRange.Count)
Dim CellToCheck As Range

ArrayCounter = 0

For Each CellToCheck In SourceRange
    If Not CellToCheck.Value = Empty Then
        ArrayCounter = ArrayCounter + 1
        myArray(ArrayCounter) = CellToCheck.Value
    Else '
        'Cell is empty, do nothing
    End If
Next CellToCheck

ReDim Preserve myArray(1 To ArrayCounter)

Set DestinationRange = DestinationRange.Resize(UBound(myArray), 1)
DestinationRange.Value = Application.Transpose(myArray)

End Sub

Answer 3

Try,

Sub test()
    Dim vDB As Variant
    Dim vR() As Variant
    Dim i As Long, n As Long, r As Long
    Dim j As Integer, c As Integer
    Dim Ws As Worksheet

    vDB = Range("b3").CurrentRegion
    r = UBound(vDB, 1)
    c = UBound(vDB, 2)
    For i = 1 To r
        For j = 1 To c
            If vDB(i, j) <> "" Then '<~~ edited mistyped vDB(i, 1) to vDB(i, j)
                n = n + 1
                ReDim Preserve vR(1 To n)
                vR(n) = vDB(i, j)
            End If
        Next j
    Next i
    Set Ws = Sheets(1)
    With Ws
        .Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
    End With
End Sub

Answer 4

Assuming:

1. the source range is A1 through I17 in Sheet1
2. the destination is Sheet2
3. the data are constants

try:

Sub dural()
    Dim rng As Range, cell As Range, WhereTo As Range
    Dim i As Long, rc As Long, arr

    Set rng = Range("A1:I17").SpecialCells(xlCellTypeConstants)
    rc = rng.Count

    Set WhereTo = Sheets("Sheet2").Range("A1:A" & rc)
    ReDim arr(1 To rc, 1 To 1)

    i = 1
    For Each cell In rng
        arr(i, 1) = cell.Value
        i = i + 1
    Next cell

    WhereTo = arr

End Sub

Note:

Using SpecialCells avoids the empties.

Answer 5

If you dispose of the FilterXML() functionality in vers. 2013+ you can try the following approach via the following steps:

• declare source & target range (see sections [0] and [1])
• assign all data in used range to a 1-dim array (see [2])
• remove the empty cells via FilterXML (see [3])
• write the array to the target column (see [4])

Sub ListAllTo1Column()
    '[0] set target range to memory and clear existing data
    Dim tgt As Range: Set tgt = Sheet2.Range("A:A")
    tgt = vbNullString    ' clear target column (before declaring source range)

    '[1] set source range to memory
    Dim src As Range: Set src = Sheet1.UsedRange

    '[2] get all data
    ReDim arr(1 To src.Cells.Count)
    Dim cell As Variant, i As Long
    For Each cell In src
        i = i + 1: arr(i) = cell
    Next cell

    '[3] remove empty cells
    arr = WorksheetFunction.FilterXML("<t><s>" & Join(arr, "</s><s>") & "</s></t>", "//s[not(.='')]")

    '[4] write results to target
    'Debug.Print Join(Application.Transpose(arr), ", ")
    tgt.Resize(UBound(arr), 1).Offset(1) = arr
End Sub

Some hints to the `FilterXML function:

The WorksheetFunction.FilterXML() gets two arguments:

1. a wellformed string of xml "nodes" with starting tags and closing tags comparable in some way to HTML;
2. a XPath query string defining which nodes (i.e. node values in VBA) you want to extract.

So arr = WorksheetFunction.FilterXML("<t><s>" & Join(arr, "</s><s>") & "</s></t>", "//s[not(.='')]")

• transforms the array items via Join() function to surround them by <s>...</s> tags in its first argument and
• defines in the second argument a XMLPath search string for any s nodes (at any hierarchy level btw due to //s) adding the condition in brackets not to search for empty values via [not(.='')] where the point abbreviation . refers to the preceding node value before the bracket.

Alternative evaluating Excel 2019's TEXTJOIN() - Edit/2020-04-28

If you dispose of the 2019 version you might use the following code snippet

Dim tmp: tmp = Split(Evaluate("=TEXTJOIN("","",True,Sheet1!" & Replace(Sheet1.UsedRange.Address, "$", "") & ")"), ",")
' Debug.Print Join(tmp, "|")

tgt.Resize(UBound(tmp), 1).Offset(1) = Application.Transpose(tmp)