How to do multiple transpose in excel vba - excel

Question

I have a list of items which are scattered, I need them all in one column, the items scattered can be brought into one column within the blank cells.
This is my requirement. The values in the first column must not change position.
I have a code which does the transpose, but its changing the position of values in the first column, its putting everything together, so the position of pink which is 9th, becomes 8th as its igonoring the blank.
Sub test3()
Dim outarr()
Nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
inarr = Range(Cells(1, 1), Cells(lr, Nc))
ReDim outarr(1 To lr * Nc, 1 To 1)
indi = 1
For i = 1 To UBound(inarr, 1)
For j = 1 To UBound(inarr, 2)
If inarr(i, j) <> "" Then
outarr(indi, 1) = inarr(i, j)
indi = indi + 1
End If
Next j
Next i
Range(Cells(1, Nc + 1), Cells(indi - 1, Nc + 1)) = outarr
End Sub
my requirement is to move the values from other columns without disturbing the 1st column.

Answer 1

Re-ractoring original code into a single loop, and adding the condition that the input index will not increment if the output hasn't 'caught up' with the input:
Option Explicit
Sub test3()
Dim outarr(), inarr()
' Change to Long as required
Dim i As Integer, j As Integer, k As Integer, lr As Integer, Nc As Integer, indi As Integer
Nc = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column + 1
lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
inarr = Range(Cells(1, 1), Cells(lr, Nc))
ReDim outarr(1 To lr * Nc, 1 To 1)
indi = 1
k = 0
' Loop over array row-wise
Do While k < lr * Nc
i = k \ Nc + 1
j = k Mod Nc + 1
' If output row not same as input row and first column is occupied, don't increment k
If inarr(i, j) <> "" Then
If indi < i And j = 1 Then
indi = indi + 1
Else
outarr(indi, 1) = inarr(i, j)
indi = indi + 1
k = k + 1
End If
Else
k = k + 1
End If
Loop
Range(Cells(1, Nc + 1), Cells(indi - 1, Nc + 1)) = outarr
End Sub

Answer 2

you can use Dictionary object
Sub test2()
With New Scripting.Dictionary
Dim cel As Range
For Each cel In Range("A1", Cells(Rows.Count, 1).End(xlUp)).SpecialCells(xlCellTypeConstants)
.Add cel.Row, Range(cel, Cells(cel.Row, Columns.Count).End(xlToLeft))
Next
Dim lastCol As Long
lastCol = Cells.Find(What:="*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim ik As Long
For ik = 0 To .Count - 1
Cells(.keys(ik), lastCol + 2).Resize(, .Items(ik).Columns.Count).Value = .Items(ik).Value
Next
End With
End Sub
just add reference to "Microsoft Scripting Runtime" library

Answer 3

Try this.
Sub ManyRowsToOneColumn()
Dim N As Long, i As Long, K As Long, j As Long
Dim sh1 As Worksheet, sh2 As Worksheet
K = 1
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
N = sh1.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
For j = 1 To Columns.Count
If sh1.Cells(i, j) <> "" Then
sh2.Cells(K, 1).Value = sh1.Cells(i, j).Value
K = K + 1
Else
Exit For
End If
Next j
Next i
End Sub
Before.
After.