Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 19:41:34
Bei VBA Ausführung Anzeige einfrieren
19.04.2024 17:05:40
Zählen von Zeilen, in denen in bestimmten Bereich Daten sind
19.04.2024 16:34:52
gemeinsamer Filter über drei Spalten
19.04.2024 15:39:42
Exceltabelle daten per combobox zu word Datei
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1252to1256
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1252to1256
1252to1256
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Neue Zeile bei nicht Identität

Neue Zeile bei nicht Identität
Manuela
Hallöchen,
ich muss erneut Eure Hilfe in Anspruch nehmen.
- Meine Daten sind von A2-J
Ich hätte jetzt gern ein kleines Makro was folgendes macht:
- Wenn Wert in C nicht Identisch mit der Zeile darunter & darüber ist, dann füge neue Zeile (nach unten) ein.
- In die Neue Zeile dann: A-C aus der alten Zeile (die darüber) und in F das Wort "blabla"
Ich hab' mal meine Datei angehängt. Dort habe ich auch schon ein Makro, allerdings funktioniert es nur so halb. Wäre nett wenn mir dort jemand den endscheidenen Tipp geben könnte was dort falsch ist.. :)
https://www.herber.de/bbs/user/79379.xls
lg,
Manu
AW: Neue Zeile bei nicht Identität
15.03.2012 15:12:51
Tino
Hallo,
kannst mal diesen Code testen.
Option Explicit

Sub ZeilenEinfuegen()
Dim n&, iCalc%
With Application
    On Error GoTo ErrorHandler:
    iCalc = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    
    With Sheets("Tabelle1 (12)") 'Tabelle anpassen 
        n = .Cells(.Rows.Count, 3).End(xlUp).Row
        If n < 3 Then Exit Sub
        
        For n = n To 3 Step -1
            If .Cells(n, 3) <> .Cells(n - 1, 3) Then
                .Cells(n, 3).EntireRow.Insert shift:=xlDown
                .Cells(n - 1, 1).Resize(, 3).Copy .Cells(n, 1)
                .Cells(n, 6) = "blabla"
            End If
        Next n
    End With

ErrorHandler:
    .Calculation = iCalc
    .EnableEvents = True
    .ScreenUpdating = True
End With

If Err.Number <> 0 Then
    MsgBox Err.Description, _
    vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
    "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub
Gruß Tino
Anzeige
AW: Neue Zeile bei nicht Identität
15.03.2012 18:11:51
Tino
Hallo,
Exit Sub ist an dieser stelle falsch, besser so.
Option Explicit
Sub ZeilenEinfuegen()
Dim n&, iCalc%
With Application
On Error GoTo ErrorHandler:
iCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
With Sheets("Tabelle1 (12)") 'Tabelle anpassen
n = .Cells(.Rows.Count, 3).End(xlUp).Row
If n > 2 Then
For n = n To 3 Step -1
If .Cells(n, 3)  .Cells(n - 1, 3) Then
.Cells(n, 3).EntireRow.Insert shift:=xlDown
.Cells(n - 1, 1).Resize(, 3).Copy .Cells(n, 1)
.Cells(n, 6) = "blabla"
End If
Next n
End If
End With
ErrorHandler:
.Calculation = iCalc
.EnableEvents = True
.ScreenUpdating = True
End With
If Err.Number  0 Then
MsgBox Err.Description, _
vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
"Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub
Gruß Tino
Anzeige
AW: Neue Zeile bei nicht Identität
15.03.2012 15:36:15
Rolf
Hallo Manuela,
wenn ich dich richtig verstanden habe, könnte das eine Lösung sein:
If ActiveCell.Value ActiveCell.Offset(-1, 0).Value And _
ActiveCell.Value ActiveCell.Offset(1, 0).Value Then
ActiveCell.EntireRow.Insert
With ActiveCell
.Value = ActiveCell.Offset(-1, -2) - ActiveCell.Offset(-1, 0)
.Offset(0, 2) = "blabla"
End With
End If
Gruß, Rolf
AW: Neue Zeile bei nicht Identität
16.03.2012 07:07:47
Manuela
Hallo Tino, Hallo Rolf
erstmal vielen Dank für Eure Hilfe! So richtig will aber leider keins der beiden Makros laufen... Mache ich evtl. was falsch?! :-(
Rolf:
Dein Makro läuft bei mir irgendwie gar nicht. Also es passiert beim Ausführen nix. Mhhh.
Tino:
Dieses Makro sieht schon ganz gut aus, aber hier werden mir zuviele Zeilen eingefügt. Hattest Du mal meine Testdatei ausprobiert?
Nochmal zu meiner Beispieldatei:
Ich möchte, dass in Spalte C nur eine neue Zeile eingefügt wird, wenn der Wert aus C nicht identisch mit der Zeile darüber & darunter ist. Wenn die Zeile darüber ODER darunter identisch ist, dann mache nix.
Heißt also:
Wenn in Zeile C der Wert darüber identisch ist, dann mache nix
Wenn in Zeile C der Wert darunter identisch ist, dann mache nix
Wenn in Zeile C der Wert darüber&darunter identisch ist, dann mache nix
Wenn in Zeile C der Wert darüber UND darunter nicht identisch ist, dann füge eine neue Zeile (nach unten)ein.
Inhalt: Werte aus A-C übernehmen aus der alten Zeile und in F der Text "blabla"
In meiner Beispieldatei dürfte z.B. nur unter den Zeilen 7,8,17,18,19,20 und 21 eine neue eingefügt werden.
LG,
Manu
Anzeige
AW: Tabellenblatt übertragen + Summe bilden
16.03.2012 13:41:48
Rolf
Hallo Manu,
tschuldige die späte Antwort, aber ich habe momentan etwas Ärger mit meiner elektrischen Datenverarbeitungsmaschine. Die gibt wirres Zeug am Bildschirm aus, ignoriert meine Passwörter und ähnliches mehr. Darf man eigentlich Truthähne (komm Puter, komm) ungestraft schlagen? - Ich bin kurz davor! Zu allem Überfluss musste ich feststellen, dass ich den dir zugeschickten Code nicht gespeichert hatte. OK, ich versuche jetzt, mich zu beruhigen.
Zurück zum Thema:
Wollte dir eigentlich deine Musterdatei samt Makro zurückschicken, aber HERBER" sagt: "Ungültiges Dateiformat". Ich nix wiss, wieso. Also muss ich das Ganse zu Fuß machen. Versuch's mal mit diesem Code:
Sub ZeileEinfügen()
'   Vor Makro-Start (Strg+z) Zelle C3 auswählen
Do Until ActiveCell.Value = ""
If ActiveCell.Value  ActiveCell.Offset(-1, 0).Value And _
ActiveCell.Value  ActiveCell.Offset(1, 0).Value And _
ActiveCell.Offset(0, -2).Value  "" Then
With ActiveCell
.Offset(1, 0).EntireRow.Insert
.Offset(1, 0).Value = ActiveCell.Offset(-1, -2).Value _
- ActiveCell.Offset(-1, 0).Value
.Offset(1, 3).Value = "blabla"
End With
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub

Bei mir funktioniert's einwandfrei.
Gruß, Rolf
Anzeige
AW: Neue Zeile bei nicht Identität
16.03.2012 17:25:34
Tino
Hallo,
demnach müsste es so gehen.
Option Explicit

Sub ZeilenEinfuegen()
Dim n&, iCalc%
With Application
    On Error GoTo ErrorHandler:
    iCalc = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    
    With Sheets("Tabelle1 (12)") 'Tabelle anpassen 
        n = .Cells(.Rows.Count, 3).End(xlUp).Row
        If n > 2 Then
            For n = n - 1 To 3 Step -1
                If .Cells(n, 3) <> .Cells(n - 1, 3) Then
                    If .Cells(n, 3) <> .Cells(n + 1, 3) Then
                        .Cells(n, 3).EntireRow.Insert shift:=xlDown
                        .Cells(n - 1, 1).Resize(, 3).Copy .Cells(n, 1)
                        .Cells(n, 6) = "blabla"
                    End If
                End If
            Next n
        End If
    End With

ErrorHandler:
    .Calculation = iCalc
    .EnableEvents = True
    .ScreenUpdating = True
End With

If Err.Number <> 0 Then
    MsgBox Err.Description, _
    vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
    "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub
Gruß Tino
Anzeige
AW: Neue Zeile bei nicht Identität
16.03.2012 18:08:16
Rolf
Hi Manu,
keine Sorge, Entschuldigung ist unnötig. Hätte dir gerne folgenden Code geschickt, aber meine elektrische Datenverarbeitungsmaschine spinnt momentan. Deshalb hier als Nachtrag (sonst wär's ja alles für de Katz):
Sub ZeileEinfügen()
Range("C3").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value  ActiveCell.Offset(-1, 0).Value And _
ActiveCell.Value  ActiveCell.Offset(1, 0).Value And _
ActiveCell.Offset(0, -2).Value  "" Then
With ActiveCell
.Offset(1, 0).EntireRow.Insert
.Offset(1, 0).Value = ActiveCell.Offset(-1, -2).Value _
- ActiveCell.Offset(-1, 0).Value
.Offset(1, 3).Value = "blabla"
End With
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Gruß, Rolf
Anzeige
AW: Neue Zeile bei nicht Identität
16.03.2012 18:54:06
Manuela
Hallo Rolf, Hallo Tino,
erstmal muss ich Euch Danken für die schnelle Hilfe. Allerdings läuft bei beiden Makros immernoch was quer :/
Tino:
Bei deinem Makro funktioniert es fast 100%ig, aber er fügt nicht überall die Identität ein wo ich es gerne hätte.
In der Beispieldatei müsste er theoretisch nach der Zeile 7,8,17,18,19,20 und 21 eine neue einfügen, weil die Zeile darüber und darunter nicht mit der Prüfzeile identisch sind.
Dein Makro fügt nur nach der 7.(8. fehlt), dann nach der 16.(Warum hier?! -- 17. fehlt), 18. und 20. (19. fehlt) eine Zeile ein. Oh Gott, was tippe ich? Ich sollte Feierabend machen... Hoffe Du verstehst mich :-)
Rolf:
Dein Makro ist echt Top und arbeitet fast genau nach meinen Vorstellungen. Die Zeilen werden alle an den richtigen Stellen eingefügt, aber in dem Bereich A-C in der neuen Zeile wollte ich den Wert aus der Ursprungszeile darüber. Dein Makro bildet die Summe in C (aus welchen Werten eigentlich? Ich werd da irgendwie nicht schlau daraus^^).
Ich hätte gern in der neuen Zeile A, den alten Wert aus A. Neue B gleicher Wert wie alt B und neu C dann alt C.
Ich Seh' nur noch Zellen und Spalten, hilfe! Was macht eigentlich deine Datenverarbeitungsmaschine, Rolf? Hast Du sie in die Schranken weisen können?^^
LG,
Manu
Anzeige
AW: Neue Zeile bei nicht Identität
16.03.2012 19:17:07
Manuela
Hi,
ich hab' mal ne Beispieldatei mit paar Kommentaren incl. Eurer Makros hochgeladen.
https://www.herber.de/bbs/user/79411.xls
LG,
Manu
AW: Neue Zeile bei nicht Identität
16.03.2012 19:21:02
Manuela
Jetzt geht bei mir alles drunter und drüber. Hab' ne alte Datei hochgeladen..
Hier jetzt die richtige Datei... grml:
https://www.herber.de/bbs/user/79412.xls
LG,
Manu
AW: Neue Zeile bei nicht Identität
16.03.2012 19:24:37
Tino
Hallo,
so mein letzter versuch.
Sub ZeilenEinfuegen()
Dim n&, iCalc%
With Application
    On Error GoTo ErrorHandler:
    iCalc = .Calculation
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    
    With Sheets("Tabelle1 (12)") 'Tabelle anpassen 
        n = .Cells(.Rows.Count, 3).End(xlUp).Row
        If n > 2 Then
            For n = n To 2 Step -1
                If .Cells(n, 3) <> .Cells(n - 1, 3) Then
                    If .Cells(n, 3) <> .Cells(n + 1, 3) Then
                        .Cells(n + 1, 3).EntireRow.Insert shift:=xlDown
                        .Cells(n, 1).Resize(, 3).Copy .Cells(n + 1, 1)
                        .Cells(n + 1, 6) = "blabla"
                    End If
                End If
            Next n
        End If
    End With

ErrorHandler:
    .Calculation = iCalc
    .EnableEvents = True
    .ScreenUpdating = True
End With

If Err.Number <> 0 Then
    MsgBox Err.Description, _
    vbCritical + vbMsgBoxSetForeground + vbMsgBoxHelpButton, _
    "Error: " & Err.Number, Err.HelpFile, Err.HelpContext
End If
End Sub
Gruß Tino
Anzeige
AW: Neue Zeile bei nicht Identität
16.03.2012 19:29:59
Manuela
Top Tino!
Es läuft jetzt fehlerfrei. Dank Dir!! :-)
LG
AW: Neue Zeile bei nicht Identität
17.03.2012 07:58:01
Rolf
Hallo Manu,
nachdem meine Kiste endlich wieder fehlerfrei arbeitet, anbei meine - etwas kürzere Lösung
Sub ZeileEinfügen()
Range("C3").Select
Do Until ActiveCell.Value = ""
If ActiveCell.Value  ActiveCell.Offset(-1, 0).Value And _
ActiveCell.Value  ActiveCell.Offset(1, 0).Value Then
'       And ActiveCell.Offset(0, -2).Value  "" Then
With ActiveCell
.Offset(1, 0).EntireRow.Insert
.Offset(1, -2).Value = ActiveCell.Offset(0, -2).Value
.Offset(1, -1).Value = ActiveCell.Offset(0, -1).Value
.Offset(1, 0).Value = ActiveCell.Offset(0, 0).Value
.Offset(1, 3).Value = "blabla"
End With
End If
ActiveCell.Offset(1, 0).Select
Loop
Range("C3").Select
End Sub
Gruß, Rolf
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige