Leerzeilentransformation superschnell

[ChristaRohn]

Liebe Excel VBA Experten,
mit meinem folgendem Programmcode lassen sich Leerzeilen über einen beliebigen Bereich sofort löschen:

Sub Leerzeilenweg()
vbBereich = "A1 :" & ActiveCell.SpecialCells(xlLastCell).Address
Range(vbBereich).SpecialCells(xlCellTypeBlanks).Delete
End Sub

Was ich nun bräuchte wäre der umgekehrte Fall. Sagen wir ich möchte in jeder zweiten Zeile wieder eine Leerzeile stehen haben. Wie füge ich diese Leerzeilen genauso schnell wieder ein?

[Rabe]

Hallo Christa,

Was ich nun bräuchte wäre der umgekehrte Fall. Sagen wir ich möchte in jeder zweiten Zeile wieder eine Leerzeile stehen haben. Wie füge ich diese Leerzeilen genauso schnell wieder ein?

also manuell würde ich es folgendermaßen machen:

1. Ich schreibe in eine Hilfsspalte eine fortlaufende Nr bei jeder belegten Zeile (in die erste eine 1, dann markieren, Doppelklick auf das kleine Kästchen rechts unten in der Zelle).
   
2. Dann kopiere ich diesen Spalteninhalt in dieselbe Spalte unter die belegten Zeilen.
   
3. Dann sortiere ich den gesamten Bereich nach der Hilfsspalte und schon habe ich unterhalb jeder belegten Zeile eine Leerzeile.
   

Diesen Vorgang nun per Rekorder aufgenommen und Du hast ein Makro, das dann noch verallgemeinert und optimiert werden könnte.

So sieht das aufgenommene erst mal aus:

Code:

Option Explicit
Sub Leerzeilen_einfügen()
'
' Leerzeilen_einfügen Makro
'

'
    Range("C2").FormulaR1C1 = "1"
    Selection.AutoFill Destination:=Range("C2:C22"), Type:=xlFillSeries
    Range("C2:C22").Select
    Selection.Copy
    Range("C23").Select
    ActiveSheet.Paste
    Range("C1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Add Key:=Range("C1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Tabelle1").Sort
        .SetRange Range("A2:C43")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

[atilla]

Hallo Christa,

hier eine Variante:

Code:

Sub jedeZweiteLeer()
   Dim i As Long
   Dim lngLetzte As Long
   Dim strgZelle As String

   lngLetzte = Cells(Rows.Count, 1).End(xlUp).Row
  
   strgZelle = Range("A2").Address
   For i = 3 To lngLetzte
      strgZelle = strgZelle & "," & Range("A" & i).Address
   Next i
  
   Range(strgZelle).EntireRow.Insert
End Sub

[atilla]

Hallo noch einmal,

das war jetzt etwas vorschnell.
Die Methode funktioniert zwar, aber hat ihre Grenze sehr schnell erreicht.
Man kann nämlich max. 255 Zeichen als String zusammenfassen und einem Range übergeben.
Das wäre hier bei 67 Zelladressen der Fall, auch nur dann , wenn man die Zelladressen nicht
Absolut (ohne Dollarzeichen) übergibt. Das war beim bisherigen Code nicht der Fall.

Unten jetzt eine korrigierte Fassung:

Code:

Option Explicit

Sub jedeZweiteLeer()
Dim i As Long, j
Dim lngLetzte As Long
Dim strgZelle As String

lngLetzte = Cells(Rows.Count, 1).End(xlUp).Row
If lngLetzte > 67 Then
   MsgBox "Mit dieser Methode können nur maximal 67 Zeilen eingefügt werden" _
      & vbLf & vbLf & "Die Ausführung wird unterbrochen!"
   Exit Sub
End If
strgZelle = Range("A2").Address(0, 0)

For i = 3 To lngLetzte
   strgZelle = strgZelle & "," & Range("A" & i).Address(0, 0)
Next i

Range(strgZelle).EntireRow.Insert
End Sub

Falls Du mehr Zeilen einfügen möchtest, dann melde Dich noch einmal.
Teile dann mit, ob es Zellen mit Formeln gibt, welche beim Einfügen und Löschen einer Hilfsspalte
in Mitleidenschaft gezogen werden würden.

[ChristaRohn]

Hallo liebe Leute,

für das Leerzeilen einfügen benutzte ich bisher immer folgenden Code:
Dim i As Integer
Dim z As Integer
Application.ScreenUpdating = False
For i = Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
For z = 1 To 1
Cells(i, 1).EntireRow.Insert Shift:=xlDown
Next z
Next i
Application.ScreenUpdating = True

das funktioniert natürlich gut. Aber ich dachte einfach an etwas genialeres! Vielleicht irgendetwas mit
einer Matrix oder so etwas?!

[schauan]

Hallo Christa,

hast Du das mit der Hilfsspalte von Rabe mal ausprobiert? Wenn Du Excel-Tabellenfunktionalitäten benutzt, gehen manche Sachen einfach und schneller. Ich habe das über 10.000 Zeilen laufen lassen - dauert unter 0,2 Sekunden. Das Wegnehmen der leeren "Zeilen" mit Deinem code dauert dann ca. 66,5 Sekunden.

Hier mal meine angepasste Variante. Ich habe die Zeilenzahl flexibel gestaltet und fange in Zeile 1 / Zelle B1 an. Statt B musst Du eine leere Spalte unmittelbar neben Deinem Tabellenbereich nehmen (wegen dem xlToLeft). Die Zeitausgabe kann dann wieder weg.

Code:

Option Explicit
'Deklaration der API-Funktion
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Sub Leerzeilenweg()
Dim vbBereich$
Dim loStartTime As Long
loStartTime = GetTickCount
vbBereich = "A1:A" & Cells(Rows.Count, 1).End(xlUp).Row
'vbBereich = "A1:" & ActiveCell.SpecialCells(xlLastCell).Address
Range(vbBereich).SpecialCells(xlCellTypeBlanks).Delete
MsgBox "Laufzeit " & _
  (GetTickCount - loStartTime) / 1000 & " Sekunden.", _
    vbInformation, "Application.Wait Soll: 3 Sekunden"
End Sub

Sub Leerzeilen_einfügen()
'
' Leerzeilen_einfügen Makro
Dim loStartTime As Long, loLastRow As Long
'Startzeit uebernehmen
loStartTime = GetTickCount
loLastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Range("B1").FormulaR1C1 = "1"
    Selection.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
        Step:=1, Stop:=10000, Trend:=False
    Range("B1:B" & loLastRow).Copy Range("B" & loLastRow + 1)
    Range("B1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    Application.CutCopyMode = False
    ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Add Key:=Range("B1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Tabelle1").Sort
        .SetRange Range("A2:B" & loLastRow * 2)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
MsgBox "Laufzeit " & _
  (GetTickCount - loStartTime) / 1000 & " Sekunden.", _
    vbInformation, "Application.Wait Soll: 3 Sekunden"
End Sub

[schauan]

Hallo Christa,

hier hab ich mal auf Basis von Ralf's code das Löschen von Leerzeilen. Bei dem Beisiel mit den 10.000 Zeilen, was mit Deinem code über eine Minute läuft, bin ich hier auch im Bereich unter 0,2 Sekunden.

Hier nutze ich wieder die Funktion GetTickCount für die Laufzeitausgabe.

Code:

Sub Leerzeilenweg2()
Dim vbBereich$
Dim loStartTime As Long, loLastRow As Long
loStartTime = GetTickCount
loLastRow = Cells(Rows.Count, 1).End(xlUp).Row

vbBereich = "A1:A" & loLastRow
'vbBereich = "A1:" & ActiveCell.SpecialCells(xlLastCell).Address
'Range(vbBereich).SpecialCells(xlCellTypeBlanks).Delete
Range(vbBereich).Offset(, 2).FormulaR1C1 = "=N(RC[-2]="""")*100000+ROW()"
    Range("C1").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToLeft)).Select
    ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Tabelle1").Sort.SortFields.Add Key:=Range("C1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Tabelle1").Sort
        .SetRange Range("A2:C" & loLastRow)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 1 & ":C" & loLastRow).Clear

MsgBox "Laufzeit " & _
  (GetTickCount - loStartTime) / 1000 & " Sekunden.", _
    vbInformation, "Application.Wait Soll: 3 Sekunden"
End Sub

[ChristaRohn]

Hallo André,

danke für den Super Profi Code. Bräuchte jetzt noch so etwas um die Leerzellen wieder einzufügen.

[Rabe]

Hi Christa,

Hallo André,

danke für den Super Profi Code. Bräuchte jetzt noch so etwas um die Leerzellen wieder einzufügen.

dann schau mal in Andrés Beitrag von 09:20 Uhr.

[ChristaRohn]

Lieber Ralf,

richtig. Ihr seid beim Lösen schneller als ich beim Lesen. Sorry!