Добавить пустые строки

Подсказка

Комментированная строка Cells(iRow + 1, cCol).Interior.ColorIndex = 3 добавляет красный цвет в первую ячейку добавленной строки, что очень помогает при попытке выяснить такой код. [ 117]

Половина версии

Sub AddBlankRows()

    Const cCol As Variant = "A"
    Const cFirstR As Long = 1

    Dim LastR As Long
    Dim iRow As Long

    LastR = Cells(Rows.Count, cCol).End(xlUp).Row

    iRow = cFirstR
    Do
        If Cells(iRow, cCol) <> "" And Cells(iRow + 1, cCol) <> "" Then
            If Cells(iRow, cCol) <> Cells(iRow + 1, cCol) Then
                Cells(iRow + 1, cCol).EntireRow.Insert xlShiftDown
                'Cells(iRow + 1, cCol).Interior.ColorIndex = 3
                LastR = LastR + 1
            End If
        End If
        iRow = iRow + 1
    Loop Until iRow > LastR

End Sub

Полная версия

Sub AddBlankRows2()

    Const cCol As Variant = "A,C"
    Const cFirstR As Long = 1

    Dim vnt As Variant
    Dim LastR As Long
    Dim iRow As Long
    Dim i As Long

    vnt = Split(cCol, ",")

    For i = 0 To UBound(vnt)

        LastR = Cells(Rows.Count, vnt(i)).End(xlUp).Row

        iRow = cFirstR
        Do
            If Cells(iRow, vnt(i)) <> "" And Cells(iRow + 1, vnt(i)) <> "" Then
                If Cells(iRow, vnt(i)) <> Cells(iRow + 1, vnt(i)) Then
                    Cells(iRow + 1, vnt(i)).EntireRow.Insert xlShiftDown
                    'Cells(iRow + 1, vnt(i)).Interior.ColorIndex = i + 3
                    LastR = LastR + 1
                End If
            End If
            iRow = iRow + 1
        Loop Until iRow > LastR
    Next

End Sub

Последняя строка в столбце, содержащем данные, определяется классической строкой:

Dim lastrownum as integer
lastrownum = cells(rows.count,icol).end(xlUp).Row

(где icol имеет значение, которое оно имеет в вашем коде). Тогда вы можете очень просто «Зациклить, а не iRow> lastrownum».

Однако вы столкнетесь с проблемой с другим вашим кодом, который вставляет пустые строки и, таким образом, перемещает «последнюю строку» вниз. Таким образом, вы должны проверить последний ряд каждого цикла. На самом деле это более простой код, просто используется на несколько мс больше времени на цикл. Вам не нужно ничего делать, кроме как изменить строку LOOP на:

LOOP UNTIL irow>cells(rows.count,icol).end(xlUp).Row

Я думаю, тебе просто нужен более чистый цикл ... это работает ...?

Sub AddBlankRows()
'
Dim iRow As Integer, iCol As Integer, oRng As Range

Set oRng = Range("a1")

iRow = oRng.Row
iCol = oRng.Column

'Need to find last row....
Dim theEND As Long
theEND = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Do While Cells(iRow, iCol).Text <> "" Or iRow <= theEND

If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
    Cells(iRow + 1, iCol).EntireRow.Insert shift:=xlDown
    iRow = iRow + 2
Else
    iRow = iRow + 1
End If

Loop

End Sub

Я бы добавил счетчик пустых строк. Тогда вы можете установить максимальный порог. Я также добавил условие выхода из бесконечного цикла, просто потому что.

Это то, что у меня есть, похоже, работает. Надеюсь, это поможет.

    Option Explicit

    Const c_intMaxBlanks As Integer = 5

    Sub AddBlankRows()

        Dim iRow As Integer, iCol As Integer
        Dim oRng As Range
        Dim intBlankCnt As Integer
        Dim intMaxBlanks As Integer
        Dim blnIsDone As Boolean
        Dim intSaveStartRow As Integer
        Dim blnStartCnt As Boolean


        blnIsDone = False

        Set oRng = Range("a1")

        iRow = oRng.Row
        iCol = oRng.Column

        blnStartCnt = False
        Do
            'Check for blank Row using length of string
            If (Len(Trim(Cells(iRow, iCol).Text)) > 0) Then
                If Cells(iRow + 1, iCol) <> Cells(iRow, iCol) Then
                    Cells(iRow + 1, iCol).EntireRow.Insert shift:=xlDown

                    iRow = iRow + 2
                Else
                    iRow = iRow + 1
                End If
            Else
              iRow = iRow + 1
            End If

            'Check for blank Row using length of string
            If (Len(Trim(Cells(iRow, iCol).Text)) < 1) Then  'Check for blank Row using length of string
                If Not blnStartCnt Then
                    intSaveStartRow = iRow
                    blnStartCnt = True
                Else
                    If (intSaveStartRow + intBlankCnt) <> iRow Then
                        'restart
                        intSaveStartRow = iRow
                        intBlankCnt = 0
                    End If
                End If

                intBlankCnt = intBlankCnt + 1
            Else
                'restart
                blnStartCnt = False
                intBlankCnt = 0
            End If


            If intBlankCnt >= c_intMaxBlanks Then blnIsDone = True

            If iRow > 500 Then
                MsgBox "Stopping Loop: Maybe Infinite"
                Exit Do
            End If

        Loop While (Not blnIsDone)

    End Sub