VBA: transpose rows into columns crashes Excel

Question

I have 1000s rows of data in 1 column that I need to transpose into columns, based on each row that is bold. The number of rows between bold ones is inconsistent, same as strings values.

I've created a simple code that worked perfectly while testing the first 100 rows. But when trying to run it through the entire list or some other parts (even 50 rows) it just stucks while running so I have to quite excel via task manager (with no error msg).

Sub Transpose_by_bold()  
    Dim x, y As Integer

    y = 1
    For x = 1 To 2000
        If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = True Then y = 1
        If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = False Then
            Range("B" & x + 1).Cut Range("B" & x).Offset(0, y)
            Range("B" & x + 1).EntireRow.Delete

            y = y + 1
            x = x - 1
        End If
  Next x
End Sub

I'd highly appreciate if you could give me a piece of idea what's wrong here?

Answer 1

Your code is currently hanging because once it moves to the end of the list X never increases, so it goes into an infinite loop. I've not tested FaneDuru's code, so it may be the answer, but the other choice would be to add some kind of escape clause to your code that bounces you out in the event of some condition you don't expect to ever happen naturally in your code - like a counter if range("b" & x).value = "" that gets reset when not true and, upon getting to some maximum value (say, 10 back to back empty cells) sets X equal to your max value (2000, in this case).

Don't forget, in the presence of weird stuff like this, you can step through your code with F8 and watch your values of X and Y in the Locals Window - if you do that, the fact that X gets stuck becomes quickly apparent.

sample counter (not terribly efficient, but it works):

Sub Transpose_by_bold()
    Dim x, y As Integer
    Dim Counter as Integer
    y = 1
    For x = 1 To 2000
     If IsEmpty(Range("B" & x + 1)) Then
           Counter = Counter + 1
     Else
           Counter = 0
     End If
     If Counter > 9 Then
         x = 2001
     End If
        If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = True Then y = 1
        If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = False Then
            Range("B" & x + 1).Cut Range("B" & x).Offset(0, y)
            Range("B" & x + 1).EntireRow.Delete

            y = y + 1
            x = x - 1
        End If

  
  Next x
End Sub

An alternate choice, I just realized (editing to note this), would be to count the maximum possible number of rows via an intersect of your column of interest and the used range of the sheet and then keep a counter that just checks how many total rows you've evaluated (your X counter right now is how many rows you'l end up with, not how many you've looked at, due to your x=x-1 line) and run your primary For loop on that total rows counter rather than on X.

Good luck!

Answer 2

Try the next code, please. I hope I could deduce the logic of your code. Especially, how to use y (incrementing the column to copy the range for each occurrence)... If the logic is correct, the code should be fast, deleting all rows at once:

Sub Transpose_by_bold()
    Dim sh As Worksheet, x As Long, y As Long, rngDel As Range
    
    Set sh = ActiveSheet 'use here your sheet
    y = 1
    For x = 1 To 2000
        If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = True Then y = 1
        If Range("B" & x).Font.Bold = True And Range("B" & x + 1).Font.Bold = False Then
            Range("B" & x).Offset(0, y).Value = Range("B" & x + 1).Value
            If rngDel Is Nothing Then
                Set rngDel = Range("B" & x + 1)
            Else
                Set rngDel = Union(rngDel, Range("B" & x + 1))
            End If
            y = y + 1
        End If
    Next x
    If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub