VBA - Swapping cells until condition is met-CodePudding

I'm new to vba and have trouble with swapping cells through a conditional loop.

I have a table which looks like

and want to transform it (move numeric cells to column b and remove non-numeric values) into

Right now I have the code

Sub Swap()

 With ThisWorkbook.Sheets("Sheet1")
     For j = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
         If IsNumeric(.Cells(j, 2)) = False Then
             For k = 2 To .Cells(j, Columns.Count).End(xlToLeft).Columns
                 Do Until IsNumeric(.Cells(j, 2)) = True
                     t = .Cells(j, k)
                     .Cells(j, k) = .Cells(j, k   1)
                     .Cells(j, k   1) = t
                 Loop
             Next k
         Else
         End If
     Next j
 End With
End Sub

which works fine until line 9, where it keeps swaping B9 and C9 in an endless loop.

I hope anyone can help me

CodePudding user response：

… It's doing exactly what you told it to.

You have a Do Until check on B9, where you swap it with cell C9. So, it starts as "ee", and you swap them. Now it is "e", so you swap them. It's "ee" again, so it swaps them again. Repeat ad nauseum

You need to rethink that Do Until. A crude Brute Force approach would be to Delete the cell with the "shift left" parameter. Another method would be to put the For k = 2.. loop inside the Do Until loop, rather than the other way around.

CodePudding user response：

When the algorithm Arive to 9's row it fall in loop because cell 2 and 3 both are unumeric (e, ee) and you're swapping them to infinity... Its better to do this steps for each row: 1- iterate all over the row's cells to find numeric one and copy that 2- clean all not needed cells and make them blank 3- fill second cell of row by copied number 4- done!

CodePudding user response：

Conditional Loop

Option Explicit

Sub Swap()

    Dim rg As Range
    With ThisWorkbook.Sheets("Sheet1")
        Dim lCell As Range
        Dim lRow As Long
        With .UsedRange
            Set lCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
            If lCell Is Nothing Then Exit Sub
            lRow = lCell.Row
            Set lCell = .Find("*", , xlFormulas, , xlByColumns, xlPrevious)
        End With
        Set rg = .Range("B1", .Cells(lRow, lCell.Column))
    End With
    
    Dim Data As Variant: Data = rg.Value
    Dim rCount As Long: rCount = UBound(Data, 1)
    Dim cCount As Long: cCount = UBound(Data, 2)
    
    Dim cValue As Variant
    Dim r As Long
    Dim c As Long
    Dim NumberFound As Boolean
    
    For r = 1 To rCount
        For c = 1 To cCount
            cValue = Data(r, c)
            If VarType(cValue) = vbDouble Then
                NumberFound = True
                Exit For
            End If
        Next c
        If NumberFound Then
            Data(r, 1) = cValue
            NumberFound = False
        Else
            Data(r, 1) = Empty ' no number found
        End If
        For c = 2 To cCount
            Data(r, c) = Empty
        Next c
    Next r
    
    rg.Value = Data

End Sub