vba

Need help about transposing rows to column

I have sets of data in excel which is to be arrange or transpose the row data after every blank in column A.

I got a code before and its actually perfect. The problem is that it will only search numbers in a column but if the cell is with letters the code will have an error.

Example 1: Column A with numbers only (OKAY)

Sheet1: enter image description here

Sheet2: RESULT PERFECT enter image description here

Example 2: Column A with letters and numbers (NOW WITH ERROR)

Sheet1: enter image description here

ERROR Message: Type Mismatch enter image description here

And this is the code that needs revision that can bear both letters and numbers.

Sub Arrange()

Dim mA As Long, nA As Long, mB As Long, nB As Long, idx As Long
Dim eRow As Long, eCol As Long
Dim LastCell As Range
Dim wsA As Worksheet, wsB As Worksheet

Set wsA = ActiveWorkbook.Sheets("Sheet1")
Set wsB = ActiveWorkbook.Sheets("Sheet2")
Set LastCell = wsA.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)

eRow = LastCell.Row
eCol = LastCell.Column

For mA = 1 To eRow
    If Not wsA.Cells(mA, 1) = 0 Then
        idx = wsA.Cells(mA, 1)
        nB = 0
    End If
    For nA = 1 To eCol
        If Not mB = idx Then mB = mB + 1
        If Not Len(wsA.Cells(mA, nA)) = 0 Then
            If mB = idx Then nB = nB + 1
            wsB.Cells(mB, nB) = wsA.Cells(mA, nA)
        End If
    Next
Next

End Sub

Thanks!

Solution

  • Transform Data

    Source

    enter image description here

    Destination

    enter image description here

    Sub ArrangeData()
    
    ' Reference the workbook.
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the source objects.
    
    Dim sws As Worksheet: Set sws = wb.Sheets("Sheet1")
    
    Dim lcell As Range
    
    Set lcell = sws.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious)
    If lcell Is Nothing Then Exit Sub
    
    Dim sRowsCount As Long: sRowsCount = lcell.Row
    Set lcell = sws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious)
    
    Dim sColsCount As Long: sColsCount = lcell.Column
    If sColsCount < 2 Then Exit Sub
    
    Dim srg As Range: Set srg = sws.Range("A1").Resize(sRowsCount, sColsCount)
    
    ' Return the values from the source range in an array.
    
    Dim sData As Variant: sData = srg.Value
    
    ' Reference a new dictionary object.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    ' Loop through the elements in the array and apply the logic...
    
    Dim Item As Variant, sRow As Long, sCol As Long, dRow As Long, dCol As Long
    
    For sRow = 1 To sRowsCount
        Item = sData(sRow, 1)
        If Len(CStr(Item)) > 0 Then
            dRow = dRow + 1
            dCol = 1
            Set dict(dRow) = CreateObject("Scripting.Dictionary")
            dict(dRow)(dCol) = Item
        End If
        For sCol = 2 To sColsCount
            Item = sData(sRow, sCol)
            If Len(CStr(Item)) > 0 Then
                dCol = dCol + 1
                dict(dRow)(dCol) = Item
            End If
        Next sCol
    Next sRow
    
    If dict.Count = 0 Then Exit Sub ' all values were blank
    
    ' Copy data.
    
    ' Reference the destination objects.
    Dim dws As Worksheet: Set dws = wb.Sheets("Sheet2")
    Dim dcell As Range: Set dcell = dws.Range("A1")
    
    ' Clear existing data.
    With dcell
        .Resize(dws.Rows.Count - .Row + 1, dws.Columns.Count - .Column + 1) _
            .Clear
    End With
    
    ' Copy new data.
    For Each Item In dict.Items
        dcell.Resize(, Item.Count).Value = Item.Items
        Set dcell = dcell.Offset(1)
    Next Item
        
    MsgBox "Data arranged.", vbInformation

End Sub