Delimit Every 23rd Row -Can't get macro to Loop properly

[Tash Point O]

Hello, Below is the macro I made to delimit data, I need it to Loop every 23rd row until 23rd row = "". However 1 of 2 things happens: The second set of data past range A2 delimits and moves all Data to Column B or the looping stops at the second set of data and it says there is no data to parse. I took the loop out of the code below but it was a do until activecell = "". Obvs I'm doing something wrong but I can't pinpoint it

[/IMG]

Here is what the data looks like unformatted:

And after I run my Macro:

 

[Domenic]

First, in future, please post your code as text and wrap them around code tags. This enables the volunteers here to simply copy and paste the code. Otherwise they wouldn't be able to do so with images.

Secondly, your row offset should be 22, not 23. Try the following...

Sub Test_New_Delimiter_Transpose()    
    Dim CompDeals As Range
    
    Set CompDeals = Range("A2")
        
    While (Len(CompDeals) > 0)
        CompDeals.TextToColumns Destination:=CompDeals.Offset(, 1), . . .
        CompDeals.ClearContents
        Set CompDeals = CompDeals.Offset(22, 0)
    Wend
        
End Sub

However, depending on the size of your data, the following may or may not be a bit more efficient...

Sub Test_New_Delimiter_Transpose()

    Dim i As Long
    Dim LastRow As Long
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To LastRow Step 22
        Cells(i, "A").TextToColumns Destination:=Cells(i, "B"), . . .
        Cells(i, "A").ClearContents
    Next i
    
End Sub

 

[Tash Point O]

First, in future, please post your code as text and wrap them around code tags. This enables the volunteers here to simply copy and paste the code. Otherwise they wouldn't be able to do so with images.

Secondly, your row offset should be 22, not 23. Try the following...


However, depending on the size of your data, the following may or may not be a bit more efficient...

Sub Test_New_Delimiter_Transpose()

    Dim i As Long
    Dim LastRow As Long
    
    LastRow = Cells(Rows.Count, "A").End(xlUp).Row
    
    For i = 2 To LastRow Step 22
        Cells(i, "A").TextToColumns Destination:=Cells(i, "B"), . . .
        Cells(i, "A").ClearContents
    Next i
    
End Sub

Dom,

Thank you for pointing out my error in image posting, I thought it looked horrid and I will do as you suggested next time for sure.

Your second code (which was concluded as more efficient) worked like a charm. Thank you very much, I really appreciate your time.

 

[Domenic]

That's great, glad I could help.

Cheers!