here is my code:

Sub transposeNumbers()
    Dim c As Range, LastRow As Long, TopN As Long, LastN As Long
    
    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
    
    For Each c In ActiveSheet.Range("A2:A" & LastRow)   
        If IsNumeric(c.Offset(-1, 0)) = True Then        
            TopN = c.Row          
        Else        
            If IsNumeric(c.Offset(1, 0)) = True Or c.Row = LastRow Then            
                LastN = c.Row                
                ActiveSheet.Range(ActiveSheet.Cells(TopN, 1), ActiveSheet.Cells(LastN, 1)).Copy
                c.Offset(0, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                Application.CutCopyMode = False            
            End If        
        End If    
    Next c
    
End Sub

My sheet looks like this:

My problem ist that is only consider minimum two of non-numerical items then it will transpose, either if I only have one non-numerical items, it won't transpose. I don't know how to fix it in that code.

I am very grateful, if you can help me out. Thanks a lot!!

CodePudding user response：

This should hopefully work for you:

Sub TransposeText()
    Dim ws As Worksheet: Set ws = Worksheets("Sheet1")
    Dim Start As Long, RowCounter As Long, i As Long
    
    With ws
        Dim Data As Range: Set Data = .Range("A1", .Range("A1").End(xlDown))
    
        For i = 1 To Data.Rows.Count   1
            If IsNumeric(Data.Item(i)) Or i = Data.Rows.Count   1 Then
                If Start < RowCounter Then
                    .Range(Data.Item(Start   1), Data.Item(RowCounter)).Copy
                    Data.Item(Start).Offset(0, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                End If
                Start = i
            Else
                RowCounter = i
            End If
        Next i
        Application.CutCopyMode = False
    End With
End Sub

CodePudding user response：

Your question is unclear, but I think this is what you want, even if it's not the most efficient way.

Sub transposeNumbers()

Dim c As Range, i As Long, rEnd As Range, rStart As Range

Set c = Range("A1")

Do Until IsEmpty(c)
    Do Until IsNumeric(c.Offset(i)) 'find number
        i = i   1
    Loop
    Set rStart = c.Offset(i   1) 'start cell to copy is after the number
    Set c = rStart
    Do Until IsNumeric(c.Offset(i)) 'then continue until find next number
        i = i   1
    Loop
    Set rEnd = c.Offset(i - 1) 'end cell to copy is before the number
    Range(rStart, rEnd).Copy
    rStart.Offset(-1, 1).PasteSpecial Transpose:=True
    Set c = rEnd.Offset(1): i = 0
Loop
    
End Sub

CodePudding user response：

Try starting the loop at row 1 not 2.

Sub transposeNumbers()
Dim c As Range, LastRow As Long, TopN As Long, LastN As Long

    LastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

    For Each c In ActiveSheet.Range("A1:A" & LastRow)
        If IsNumeric(c) = True Then
            TopN = c.Row
        Else
            If IsNumeric(c.Offset(1, 0)) = True Or c.Row = LastRow Then
                LastN = c.Row
                ActiveSheet.Range(ActiveSheet.Cells(TopN, 1), ActiveSheet.Cells(LastN, 1)).Copy
                c.Offset(0, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                Application.CutCopyMode = False
            End If
        End If
    Next c

End Sub

Before

After