How to do multiple transpose in excel vba

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.

what if any line has more items than the available empty rows below? e.g.: first line = apple, orange, grapes, anotherOne — user3598756
– user3598756, Commented Jan 21, 2023 at 17:43

Tom Sharpe · Accepted Answer · 2023-01-22 08:19:33Z

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

user3598756 · Accepted Answer · 2023-01-21 18:20:39Z

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

ASH · Accepted Answer · 2023-01-24 03:44:58Z

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.

Collectives™ on Stack Overflow

How to do multiple transpose in excel vba

3 Answers 3

Comments

Comments

Comments

Linked

Hot Network Questions

Collectives™ on Stack Overflow

3 Answers 3

Comments

Comments

Comments

Linked

Related