列中的数据更改后插入空白行

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=""

它在空行处停止工作。我需要它忽略空行，并且仅当范围内没有剩余数据时才停止。有任何想法吗？我在编码方面很新！

然后，我放入代码以在第一列的每次数据更改之间插入一个空行。现在，我需要运行第二个代码，该代码将在第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

经典行找到包含数据的列中的最后一行：

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

Answer 3

添加空白行

提示

注释行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 4

我认为您只需要一个更清洁的循环...这行得通吗...？

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