Ich habe diesen Code in einem früheren Thread gefunden. Nach einer Datenänderung wird eine leere Zeile eingefügt.

Hier ist es:

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

Es funktioniert großartig, aber aufgrund dieses Teils:

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

Bei leeren Zeilen funktioniert es nicht mehr. Ich brauche es, um leere Zeilen zu ignorieren und nur dann anzuhalten, wenn keine Daten mehr im Bereich sind. Irgendwelche Ideen? Ich bin sehr neu im Codieren!

This is what my data looks like at first:

Dann habe ich den Code eingegeben, um zwischen jeder Datenänderung in der ersten Spalte eine leere Zeile einzufügen. Jetzt muss ich einen zweiten Code ausführen, der zwischen jeder Datenänderung in der 3. Spalte eine leere Zeile einfügt. Das würde also so aussehen:

image

1
Jean 20 Jän. 2019 im 00:08

4 Antworten

Beste Antwort

Ich würde einen Leerzeilenzähler hinzufügen. Dann können Sie einen maximalen Schwellenwert eingeben. Ich habe auch eine Endlosschleifen-Ausgangsbedingung hinzugefügt, nur weil.

Dies ist, was ich habe, das zu funktionieren scheint. Ich hoffe, es hilft.

    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

1
IAmNerd2000 20 Jän. 2019 im 06:18

Die letzte Zeile in einer Spalte, die Daten enthält, wird in der klassischen Zeile gefunden:

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

(wobei icol die Bedeutung hat, die es in Ihrem Code hat). Dann können Sie ganz einfach "Loop While Not iRow> lastrownum".

Sie führen jedoch ein Problem mit Ihrem anderen Code ein, der Leerzeilen einfügt und somit die "letzte Zeile" jemals nach unten verschiebt. Sie müssen also in jeder Schleife nach der letzten Zeile suchen. Dies ist eigentlich einfacher Code, benötigt nur ein paar ms mehr Zeit pro Schleife. Sie müssen nichts weiter tun, als die LOOP-Zeile in Folgendes zu ändern:

LOOP UNTIL irow>cells(rows.count,icol).end(xlUp).Row
0
Roy Brander 19 Jän. 2019 im 23:32

Leere Zeilen hinzufügen

Trinkgeld

Die kommentierte Zeile Cells(iRow + 1, cCol).Interior.ColorIndex = 3 fügt der ersten Zelle der hinzugefügten Zeile eine rote Farbe hinzu, was sehr hilfreich ist, wenn Sie versuchen, einen solchen Code herauszufinden.

Halbe Version

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

Vollversion

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
0
VBasic2008 20 Jän. 2019 im 02:07

Ich denke, Sie brauchen nur eine sauberere Schleife ... funktioniert das ...?

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
0
PGSystemTester 20 Jän. 2019 im 03:17