VBA: перенос строк в столбцы приводит к сбою Excel

Question

У меня есть 1000 строк данных в 1 столбце, которые мне нужно транспонировать в столбцы на основе каждой строки, выделенной жирным шрифтом. Количество строк между полужирным шрифтом несовместимо, как и значения строк.

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

Я был бы очень признателен, если бы вы могли дать мне часть идеи что здесь не так?

Answer 1

Ваш код в настоящее время зависает, потому что, когда он перемещается в конец списка, X никогда не увеличивается, поэтому он переходит в бесконечное l oop. Я не тестировал код FaneDuru, так что это может быть ответ, но другим вариантом было бы добавить в ваш код какое-то предложение escape, которое оттолкнет вас в случае какого-то условия, которое вы не ожидаете когда-либо произойти естественным образом. в вашем коде - как счетчик if range ("b" & x) .value = "", который сбрасывается, когда не истинно, и при достижении некоторого максимального значения (скажем, 10 спина к пустым ячейкам) устанавливает X равным вашему максимальное значение (в данном случае 2000).

Не забывайте, что при наличии таких странных вещей, вы можете пошагово пройти свой код с помощью F8 и посмотреть свои значения X и Y в окне локальных переменных - если вы это сделаете, тот факт, что X застревает, становится очевидным.

счетчик выборок (не очень эффективен, но работает):

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

Альтернативный вариант, я только что понял (редактирование, чтобы отметить это), было бы подсчитать максимально возможное количество строк через пересечение интересующего столбца и используемого диапазона листа, а затем сохранить счетчик, который просто проверяет, как много общих строк, которые вы оценили (ваш счетчик X прямо сейчас показывает, сколько строк вы получите, а не сколько вы просмотрели, из-за вашей строки x = x-1) и запустите свой основной For l oop на этом счетчике общего количества строк, а не на X.

Удачи!

Answer 2

Попробуйте следующий код, пожалуйста. Я надеюсь, что смогу вывести лог c вашего кода. В частности, как использовать y (увеличение столбца для копирования диапазона для каждого вхождения) ... Если logi c правильный, код должен быть быстрым, удаляя все строки сразу:

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