Вставка пустых строк после изменения данных в столбце

Question

Я нашел этот код в предыдущей теме. Вставляет пустую строку после изменения данных.

Вот оно:

sub AddBlankRows()
'
dim iRow as integer, iCol as integer
dim oRng as range

set oRng=range("a1")

irow=oRng.row
icol=oRng.column

do 
'
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 while not cells (irow,iCol).text=""
'
end sub

Отлично работает, но из-за этой части:

loop while not cells (irow,iCol).text=""

перестает работать на пустых строках. Мне нужно, чтобы он игнорировал пустые строки и останавливался только тогда, когда в диапазоне больше не осталось данных. Есть идеи? Я очень новичок в кодировании!

Затем я вставил код для вставки пустой строки между каждым изменением данных в 1-м столбце. Теперь мне нужно запустить второй код, который вставлял бы пустую строку между каждым изменением данных в 3-й колонке, чтобы это выглядело так:

Answer 1

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

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

    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

Answer 2

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

Совет

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

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

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

Answer 3

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

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

Answer 4

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

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

(где icol имеет значение, которое оно имеет в вашем коде). Тогда вы можете очень просто "Loop While Not iRow> lastrownum".

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

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