How to do multiple transpose in excel vba-CodePudding

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.

CodePudding user response：

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

CodePudding user response：

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()
    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