Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1020to1024
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Zeilen einfügen nach Wertwechsel

Zeilen einfügen nach Wertwechsel
30.10.2008 11:31:00
Marcus
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

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

Betreff
Datum
Anwender
Anzeige
AW: Der Wert in Spalte "B" kann nicht...
30.10.2008 12:00:00
Chris
... 1 sein. Welche Zelle ist die Zieladresse ? B1, B2, B3..., oder gilt das für alle Zellen in Spalte B ?
Gruß
Chris
AW: Der Wert in Spalte "B" kann nicht...
30.10.2008 12:19:00
Marcus
Hallo,
es gilt in Spalte B für eine Zellenanzahl von 3000, das immer wenn eine Zelle eine "1" enthält (unregelmäßig wiederkehrend), eine Zeile zuvor eingefügt werden soll.
Verständlich? Kann es nicht besser umschreiben.
Vielen Dank
marcus leu
AW: Nachfrage
30.10.2008 12:27:00
Chris
servus Marcus,
soweit klar. Steht nach der Zeile 3000 irgendetwas in der Tabelle, sind die 3000 die maximale Anzahl an Zeilen ?
Gruß
Chris
AW: Nachfrage
30.10.2008 12:35:00
Marcus
Hallo,
Steht nach der Zeile 3000 irgendetwas in der Tabelle,
nein
sind die 3000 die maximale Anzahl an Zeilen ?
ja
Alternativ: Durchlauf bis zur letzten Zelle der Spalte (65000 irgendwas ?)
Vielen Dank
Marcus Leu
Anzeige
AW: Nachfrage
30.10.2008 12:42:00
Chris
Servus,
ich schreib dir was. Das Problem ist eben, wenn 10 Zeilen eingefügt werden sollen, aber nach der letzten beschriebenen Zelle (z.B.: B66528) nur noch für 8 Platz ist, gibts mitunter einen Fehler der zum Abbruch führt.
Deswegen hab ich auch gefragt.
Gruß
Chris
AW: Nachfrage
30.10.2008 12:45:00
Marcus
Hallo,
stimmt, 3000 Zeilen zu durchlaufen reicht auf jeden Fall.
Vielen Dank Dir
marcus leu
AW: Nachfrage
30.10.2008 13:36:00
Marcus
Hallo Chris,
hatte mich schon mal versucht, aber ... es funktioniert so nicht.

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


marcus leu

Anzeige
AW: Nachfrage
30.10.2008 14:34:42
Christian
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

Anzeige
AW: Nachfrage
30.10.2008 15:01:00
Marcus
Hallo Christian,
ich bewundere das, ganz ehrlich, sehr!
Schleifendurchlauf dauert eben, Funktioniert aber einwandfrei!
Würdest Du mir nochmals helfen und zwar ein neues Makro, welches die Leerzeilen wieder löscht?
Und mal 'ne Frage nebenbei, ist das für dich Hobby, Beruf oder ...?
Vielen Dank
Marcus Leu
AW: Nachfrage
30.10.2008 15:41:32
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

Anzeige
AW: Nachtrag
30.10.2008 15:48:44
Chris
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
Anzeige
AW: Nachtrag
30.10.2008 15:59:00
Marcus
Hallo,
vielen, vielen Dank!
Marcus Leu

317 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige