Cell transposition in a specific row

Question

I develop this code to transpose excel line for non-numeric contents, but I would to transpose the excel line on the same row, where I have the numeric content. Please refer to the uploaded picture. But somehow my code transpose and copy the contents on the last row, before it goes to the next numeric contents. Each numeric contents means a new order no, and the non-numeric are the articles, which customer order.

Second Problem: If I only have one non-numeric item, it doesn't transpose at all. So what is the problem?

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

Answer 1

Your Paste operation is referring to the wrong line.

In addition, it is best practice, in general, to avoid using ActiveSheet. Refer instead to the specific worksheet.

Code below shows the corrections:

Option Explicit

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

'Avoid "ActiveSheet". Declare the specific worksheet
Dim WS As Worksheet
Set WS = ThisWorkbook.Worksheets("sheet3")

With WS
    LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    
    For Each c In .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
                .Range(.Cells(TopN, 1), .Cells(LastN, 1)).Copy
                
        'change this line to correct your error
                .Cells(TopN, 1).Offset(-1, 2).PasteSpecial Paste:=xlPasteAll, Transpose:=True
                
                Application.CutCopyMode = False
            End If
        End If
    Next c
End With

End Sub

Edit

Especially in light of your comments, I would use a different method to create your desired output.

For speed of execution, it is usually much faster to create your desired output entirely within VBA, and then write it out to the worksheet.

Reads and writes to/from worksheet ranges and VBA arrays can be done in a single step. And iterating through a VBA array can be five to ten times faster than iterating through cells on a worksheet.

Accordingly, the code below:

• reads the source data into a VBA array
• loops through column 1 of the source data
  • if a value is numeric, start a collection of the next "text" values which will be stored in the dictionary, and the key for that entry will be the desired row number.
• once we have completed this dictionary of collections, create an output array and populate it.
• read the code comments to better understand.

Option Explicit
Sub TransposeAtNumber()
    Dim WS As Worksheet, vSrc As Variant, vRes As Variant
    Dim rRes As Range
    Dim col As Collection, dict As Object
    Dim I As Long, J As Long, lRow As Long
    Dim numCols As Long, v As Variant
    

'Declare the worksheet
Set WS = ThisWorkbook.Worksheets("Sheet2")

'Read the table into a variant array for fastest processing
With WS
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=2)
End With

'collect the transposed values into collection and each
'  collection into a dictionary with Key being the appropriate row

Set dict = CreateObject("Scripting.Dictionary")
For I = 2 To UBound(vSrc, 1) 'starting at 2 because of header row
    If IsNumeric(vSrc(I, 1)) Then
        Set col = New Collection
        lRow = I
        dict.Add lRow, col
    Else
        dict(lRow).Add vSrc(I, 1)
    End If
Next I

'size vres
'rows will be same as vSrc
'columns will be the size of the largest collection

For Each v In dict
    numCols = IIf(numCols > dict(v).Count, numCols, dict(v).Count)
Next v
ReDim vRes(1 To UBound(vSrc, 1), 1 To numCols)

'Populate vres
For Each v In dict
    For J = 1 To dict(v).Count
        vRes(v, J) = dict(v)(J)
    Next J
Next v

'clear the destination area (or larger if you will)
'and write the results back to the worksheet

Application.ScreenUpdating = False
Set rRes = WS.Cells(1, 3).Resize(rowsize:=UBound(vRes, 1), columnsize:=numCols) 'or numCols +1 if you need to leave a border
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .Style = "Output" 'this is NOT internationally aware
    .EntireColumn.AutoFit
End With
    
End Sub