How to do multiple transpose in excel vba

Question

I need all the things on a list that is dispersed into one column. The scattered items can be arranged into one column by placing them inside the empty cells.

This is what I demand. The first column's values can't move from their original positions. I have a code that performs the transposition, but it rearranges the values in the first column by grouping them all together. As a result, the position of pink, which is ninth, is changed to eighth because the blank is ignored.

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

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