Zeilen einfügen nach Wertwechsel

Marcus · 2008-10-30T11:31:00+00:00

Hallo, benötige folgende Hilfe bei EXCEL/VBA: eine Zeile soll eingefügt werden, wenn der Wert in Spalte B "1" ist. Die Zeile soll vor der Zelle/Zeile mit dem Wert eingefügt werden. Danke für die Hilfe Marcus Leu

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

Servus Marcus,
reines Hobby.


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

geht schnell berücksichtigt aber nicht, ob in den anderen Zellen der Zeile etwas steht


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

das 2. Makro prüft erst noch, ob sonst irgendetwas in der Zeile steht, in der in B nichts steht.
Gruß
chris

Zeilen einfügen nach Wertwechsel

Forumthread: Zeilen einfügen nach Wertwechsel

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Zeilen einfügen nach Wertwechsel

Forumthread: Zeilen einfügen nach Wertwechsel

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

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread