(VBA) Excel with thousands of rows - how to transpose variable length columns to rows?

Question

I have an Excel sheet I am working with 9948 rows. A cell would have multiple pieces of information contained within it so what I've done so far is delimit those through Excel's text-to-column feature.

(All data and column headers are arbitrary)

It started out like this:

 ID | Name |           Property1          |
 1    Apple     JO18, GFBAJH, HFDH, 78EA

It has data (in mixed text/number format) in the first couple columns that should actually be on their own row. The amount of properties one of these have varies so one might have five properties and another might have 20. It looks something like this after I've delimited the rows:

 ID | Name | Property1| Property2 | Property3 | Property4 | Property5 | Property6 |
 1    Apple    J012       B83A        G5DD      
 2    Banana   RETB       7CCV
 3    Orange   QWER       TY          YUIP      CVBA        UBBN         FDRT
 4    Pear     55V        DWZA        6FJE      LKOI        PAKD
 5    Cherry   EEF        AGC         TROU

What I've been trying to accomplish is to get it to look like this:

    ID | Name | Property1| Property2 | Property3 | Property4 | Property5 | Property6 |
 1      Apple    J012       
                 B83A        
                 G5DD      
 2      Banana   RETB       
                 7CCV
 3      Orange   QWER       
                 TY          
                 YUIP      
                 CVBA        
                 UBBN         
                 FDRT
 4      Pear     55V        
                 DWZA        
                 6FJE      
                 LKOI        
                 PAKD
 5      Cherry   EEF        
                 AGC         
                 TROU   

I've been able to go through manually and transpose the data for each row, which has resulted in over 33,000 rows. This was very time consuming and I don't doubt that I made some errors here and there so I wanted to explore a way to automate it.

I've explored recording a macro by copying the row, pasting it at the bottom, copying the additional properties and transposing them below Property1 but every time I try to repeat this it only pastes to same row and never has the variable sizing of the row length. I've commented it out in the macro where I was attempting to increment by 1 but it gave a 'type mismatch' error

Recorded macro:

Sub Macro1()
'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+Shift+A
'
   Selection.Copy
   ActiveWindow.ScrollRow = 9922
   ActiveWindow.SmallScroll Down:=3
   'Range("A9948").Value = Range("A9948").Value + 1
   Range("A9948").Select
   ActiveSheet.Paste
   ActiveWindow.SmallScroll Down:=6
   Range("E9948:Z9948").Select
   Application.CutCopyMode = False
   Selection.Copy
   Range("D9949").Select
   Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=  _
        False, Transpose:=True
End Sub

Any help would be appreciated.

Answer 1

Try this code. The input range is the first column from Apple to Cherry.

Set Rng = Sheets("sheet1").Range("B2:B6")   'Input range of all fruits
Set Rng_output = Sheets("sheet2").Range("B2")   'Output range

For i = 1 To Rng.Cells.Count
    Set rng_values = Range(Rng.Cells(i).Offset(0, 1), Rng.Cells(i).End(xlToRight)) 'For each fruit taking the values to the right which need to be transposed

    If rng_values.Cells.Count < 16000 Then 'To ensure that it doesnt select till the right end of the sheet
        For j = 1 To rng_values.Cells.Count
                Rng_output.Value = Rng.Cells(i).Value
                Rng_output.Offset(0, 1).Value = rng_values.Cells(j).Value
                Set Rng_output = Rng_output.Offset(1, 0)  'Shifting the output row so that next value can be printed
        Next j
    End If
Next i

Create an excel file with the data as shown in the input and run the code stepwise to understand it

Answer 2

Is this the outcome you are after?

Option Explicit

Public Sub TransposeRows()
    Dim i As Long, j As Long, k As Long, ur As Variant, tr As Variant
    Dim thisVal As String, urMaxX As Long, urMaxY As Long, maxY As Long

    With Sheet1
        ur = .UsedRange
        urMaxX = UBound(ur, 1)
        urMaxY = UBound(ur, 2)
        maxY = urMaxX * urMaxY
        ReDim tr(2 To maxY, 1 To 3)
        k = 2
        For i = 2 To urMaxX
            For j = 2 To urMaxY
                thisVal = Trim(ur(i, j))
                If Len(thisVal) > 0 Then
                    If j = 2 Then
                        tr(k, 1) = Trim(ur(i, 1))
                        tr(k, 2) = Trim(ur(i, 2))
                        tr(k, 3) = Trim(ur(i, 3))
                        j = j + 1
                    Else
                        tr(k, 3) = thisVal
                    End If
                    k = k + 1
                Else
                    Exit For
                End If
            Next
        Next
        .UsedRange.Offset(1).Clear
        .Range(.Cells(2, 1), .Cells(maxY, 3)) = tr
    End With
End Sub

---

Before

After