Zeilen einfügen nach Wertwechsel

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Der Wert in Spalte "B" kann nicht...

30.10.2008 12:00:00

Chris

AW: Der Wert in Spalte "B" kann nicht...

30.10.2008 12:19:00

Marcus

AW: Nachfrage

30.10.2008 12:27:00

Chris

AW: Nachfrage

30.10.2008 12:35:00

Marcus

AW: Nachfrage

30.10.2008 12:42:00

Chris

AW: Nachfrage

30.10.2008 12:45:00

Marcus

AW: Nachfrage

30.10.2008 13:36:00

Marcus

AW: Nachfrage

30.10.2008 14:34:42

Christian

AW: Nachfrage

30.10.2008 15:01:00

Marcus

AW: Nachfrage

30.10.2008 15:41:32

Chris

AW: Nachtrag

30.10.2008 15:48:44

Chris

AW: Nachtrag

30.10.2008 15:59:00

Marcus

Sub einfügen() Dim n As Integer Dim lngLetZeile As Long lngLetZeile = IIf(Range("A65536") "", 65536, Range("A65536").End(xlUp).Row) For n = 2 To lngLetZeile If Cells(n + 1, 2) = 1 Then Cells(n + 1, 2).EntireRow.Insert Shift:=xlDown Next n End Sub

Servus Marcus,
das macht man immer von unten:
Ich hab dir was mit Rucksack und Hosenträger geschrieben.
Das Makro berücksichtigt die möglichen einzufügenden Zeilen, ob die letzte beschrieben ist, ob überhaupt Zeilen eingefügt werden müssen, oder ob schon eine Leerzeile vorhanden ist.
Der Bereich geht von B1 bis zur letzten beschriebenen Zelle in Spalte B:


Sub reinda()
Dim rSuche As Range, rFinde As Range, strErste As String
Dim AdressArray() As Long, x As Long, z As Long, nachricht As String, AdressArrayEin() As Long
Dim OG&, i&, j&, k&, h As Variant, y As Long
Dim LetzteZeile As Long
LetzteZeile = Cells.Find(what:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious, LookIn:= _
xlFormulas).Row
If Range("B1").Value = 1 Then Range("B1").EntireRow.Insert shift:=xlDown
Set rFinde = Range("B2:B" & Cells(Rows.Count, 2).End(xlUp).Row)
Set rSuche = rFinde.Find(what:=1, LookAt:=xlWhole, LookIn:=xlValues)
If Not rSuche Is Nothing Then
strErste = rSuche.Address
Do
ReDim Preserve AdressArrayEin(x)
AdressArrayEin(x) = rSuche.Row
x = x + 1
Set rSuche = rFinde.FindNext(rSuche)
Loop While Not rSuche Is Nothing And strErste  rSuche.Address
Else
Exit Sub
End If
ReDim AdressArray(0)
For z = LBound(AdressArrayEin()) To UBound(AdressArrayEin())
On Error Resume Next
If Not Range("A" & AdressArrayEin(z) - 1 & ":IV" & AdressArrayEin(z) - 1).Find(what:=" _
*", LookIn:=xlValues) Is Nothing Then
ReDim Preserve AdressArray(y)
AdressArray(y) = AdressArrayEin(z)
y = y + 1
End If
Next z
If 65536 - LetzteZeile = 0 Then
MsgBox " Einfügen ist nicht möglich! Die letzte Zeile ist beschrieben!", vbCritical, " _
Abbruch"
Exit Sub
Else
If 65536 - LetzteZeile  0
For i = LBound(AdressArray()) To OG - k
j = i
While (j >= 0) And (AdressArray(j) > AdressArray(j + k))
h = AdressArray(j)
AdressArray(j) = AdressArray(j + k)
AdressArray(j + k) = h
If j > k Then
j = j - k
Else
j = LBound(AdressArray())
End If
Wend
Next i
k = k \ 2
Wend
On Error Resume Next
For z = UBound(AdressArray()) To LBound(AdressArray()) Step -1
If Not AdressArray(z) = 1 Then
If Not Range("A" & AdressArray(z) - 1 & ":IV" & AdressArray(z) - 1).Find(what:="*", LookIn:= _
xlValues) Is Nothing Then
Range("B" & AdressArray(z)).EntireRow.Insert shift:=xlDown
End If
Else
Range("B" & AdressArray(z)).EntireRow.Insert shift:=xlDown
End If
Next z
On Error GoTo 0
End Sub

Gruß
Chris

Sub lösch() Dim lngLetzte As Long lngLetzte = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count) Range("B1:B" & lngLetzte).SpecialCells(xlCellTypeBlanks).EntireRow.Delete End Sub

Sub lösch2() Dim Zelle As Range, Bereich As Range, x As Long, LöschArray() As Long Set Bereich = Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row) For Each Zelle In Bereich.SpecialCells(xlCellTypeBlanks) ReDim Preserve LöschArray(x) LöschArray(x) = Zelle.Row x = x + 1 Next Zelle For i = UBound(LöschArray()) To LBound(LöschArray()) Step -1 'MsgBox LöschArray(i) If Range("A" & LöschArray(i) & ":IV" & LöschArray(i)).Find(what:="*", LookIn:=xlValues) Is _ Nothing Then Rows(LöschArray(i)).Delete End If Next i End Sub

Servus Marcus,
in dem Makroteil (1.Makro / einfügen) fehlte noch was:
statt:
ReDim AdressArray(0)
For z = LBound(AdressArrayEin()) To UBound(AdressArrayEin())
On Error Resume Next
If Not Range("A" & AdressArrayEin(z) - 1 & ":IV" & AdressArrayEin(z) - 1).Find(what:=" _
*", LookIn:=xlValues) Is Nothing Then
ReDim Preserve AdressArray(y)
AdressArray(y) = AdressArrayEin(z)
y = y + 1
End If
Next z
besser:
ReDim AdressArray(0)
For z = LBound(AdressArrayEin()) To UBound(AdressArrayEin())
On Error Resume Next
If Not Range("A" & AdressArrayEin(z) - 1 & ":IV" & AdressArrayEin(z) - 1).Find(what:=" _
*", LookIn:=xlValues) Is Nothing Then
ReDim Preserve AdressArray(y)
AdressArray(y) = AdressArrayEin(z)
y = y + 1
End If
On Error goTo 0
Next z
sonst kommt die falsche Fehlermeldung. Das verhindert das Zurücksetzten des Fehlers mit On Error goTo 0
Gruß
Chris

Beliebteste Forumthreads (12 Monate)

Zeilen einfügen nach Wertwechsel

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

317 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Zeilen einfügen nach Wertwechsel

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

317 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread