Kopieren von Formeln mit Bedingung

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
MsgBox
Bild

Betrifft: Kopieren von Formeln mit Bedingung
von: EasyD
Geschrieben am: 29.11.2015 15:14:11

Hallo Zusammen
ich bin gerade dabei, mir aus diversen in Internetforen gefundenen Code-Bruchstücken mein Marko zu bauen. Das ganze tatsächlich selbst zu bauen schaffe ich noch nicht, bin Autodidakt was VBA angeht.....
Ich habe eine Spalte I, in der entweder "gebucht" oder nichts steht.
Wenn dort nichts steht, dann sollen die Spalten A bis G der ersten Zeile darüber (= die letzte Zeile, in der noch "gebucht" steht) einfach eins nach unten in die soeben gefundene Zeile ausgefüllt werden. Klingt an sich nicht so kompliziert, ist es aber für mich.
Hintergrund ist, dass der Kenner "gebucht" nach diesem Kopiervorgang durch einen weiteren Vorgang erst gesetzt wird.
Der bisherige Code dazu:

Sub Test()
Dim ums As Worksheet, buch As Worksheet
Dim x As Long, y As Long, lngZeilen As Long
Dim lnterstefrei As Long
Set ums = Worksheets("Umsatzliste")
Set buch = Worksheets("Buchungsliste")
lngZeilen = ums.Cells(ums.Rows.Count, 2).End(xlUp).Row
x = 2
For y = 1 To lngZeilen
If ums.Cells(y, 9).Value Like "gebucht" Then
'bei "gebucht" nichts machen, sonst:
Else
Worksheets("Umsatzliste").Select
'jetzt fehlt noch die Funktion - wenn die gebucht-Zelle (=Else) leer ist, dann nimm die Spalten  _
A bis G von der ZEILE DARÜBER und kopiere sie eins nach unten
'Kopieren der Spaten A bis G (=die soeben mit der noch fehlenden Funktion erstellten Zellen):
ums.Range(Cells(y, 1), Cells(y, 7)).copy
'Einfügen der kopierten WERTE in die Spalten A bis G der Buchungsliste:
Worksheets("Buchungsliste").Select
buch.Cells(buch.Cells(Rows.Count, 2).End(xlUp).Row + 1, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'setzen des Kenners "gebucht" nach Durchführung dieser Aktion
ums.Cells(y, 9).Value = "gebucht"
lngY = lngY + 1 'lngy + 1
                
x = x + 1
End If
Next y
End Sub

ich bin mal gespannt was so für Lösungsansätze kommen. Ich freu mich auf eure Hilfe.
Grüße

Bild

Betrifft: ungetestet
von: Michael
Geschrieben am: 29.11.2015 18:00:20
Hi EasyD,
1. sind die Worksheet("..").Select nicht nötig, da Du ja über die Variablen "ums" und "buch" direkt auf die Tabellenblätter zugreifst - einfach auskommentiert.
2. weißt Du ja bereits, wie Du einen Bereich kopierst:

ums.Range(Cells(y, 1), Cells(y, 7)).copy

Die Zeile vorher ist schlicht jeweils y-1, also so:
ums.Range(Cells(y-1, 1), Cells(y-1, 7)).copy

Weil die Schleife ab y=1 läuft, *könnte* es aber sein, daß, wenn hier nix steht, Cells(1-1,..) kopiert werden soll, Cells(0,..) gibt es aber nicht.
Alles zusammen *könnte* (wie gesagt, ungetestet) etwa so funktionieren:
Sub Test()
Dim ums As Worksheet, buch As Worksheet
Dim x As Long, y As Long, lngZeilen As Long
Dim lnterstefrei As Long
Set ums = Worksheets("Umsatzliste")
Set buch = Worksheets("Buchungsliste")
lngZeilen = ums.Cells(ums.Rows.Count, 2).End(xlUp).Row
x = 2
For y = 1 To lngZeilen
If not ums.Cells(y, 9).Value Like "gebucht" Then
 If y >1 then
   ums.Range(ums.Cells(y-1, 1), ums.Cells(y-1, 7)).copy ums.Cells(y, 1)
  else
   msgbox "y=1; das geht nicht."
 End If
End if
ums.Range(ums.Cells(y, 1), ums.Cells(y, 7)).copy
'Einfügen der kopierten WERTE in die Spalten A bis G der Buchungsliste:
buch.Cells(buch.Cells(buch.Rows.Count, 2).End(xlUp).Row + 1, 1). _
    PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
'setzen des Kenners "gebucht" nach Durchführung dieser Aktion
ums.Cells(y, 9).Value = "gebucht"
lngY = lngY + 1 'lngy + 1
                
x = x + 1
End If
Next y
End Sub
Schöne Grüße,
Michael
P.S.: wenn es nicht läuft, lade bitte ne Beispieldatei "zum Spielen" hoch.

Bild

Betrifft: Nachtrag
von: Michael
Geschrieben am: 29.11.2015 18:10:14
Hi, ich habe übersehen, daß es sich um Formeln handelt.
Also füge sie dann entweder (wie weiter unten in Deinem Code) mit PasteSpecial ein oder ersetze den kompletten If-Block wie folgt:

If Not ums.Cells(y, 9).Value Like "gebucht" Then
 If y > 1 Then
   ums.Range(ums.Cells(y, 1), ums.Cells(y, 7)).Value = _
   ums.Range(ums.Cells(y - 1, 1), ums.Cells(y - 1, 7)).Value
  Else
   MsgBox "y=1; das geht nicht."
 End If
End If
Schöne Grüße,
Michael

Bild

Betrifft: AW: Nachtrag
von: EasyD
Geschrieben am: 01.12.2015 21:07:28
Hallo Michael
Danke für die Mühe - ich hatte aber noch einen Geistesblitz bevor ich deine Antwort gelesen habe.
Also:

Sub Test()
Dim ums As Worksheet, buch As Worksheet
Dim x As Long, y As Long, lngZeilen As Long
Dim lnterstefrei As Long
Set ums = Worksheets("Umsatzliste")
Set buch = Worksheets("Buchungsliste")
Worksheets("Umsatzliste").Select
    Range("A3:H3").Select
    Selection.copy
    Range("J1").Select
    Selection.End(xlDown).Select
    Selection.End(xlDown).Select
    Selection.End(xlToLeft).Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
lngZeilen = ums.Cells(ums.Rows.Count, 2).End(xlUp).Row
x = 2
For y = 1 To lngZeilen
'If IsEmpty(ums.Cells(y, 10)) = True Then
If ums.Cells(y, 9).Value Like "gebucht" Then
'bei "gebucht" nichts machen, sonst:
Else
'Kopieren der Spaten A bis G (=die soeben mit der noch fehlenden Funktion erstellten Zellen):
ums.Range(Cells(y, 1), Cells(y, 7)).copy
'und Einfügen der kopierten WERTE in die Spalten A bis G der Buchungsliste:
buch.Cells(buch.Cells(Rows.Count, 2).End(xlUp).Row + 1, 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
ums.Cells(y, 9).Value = "gebucht"
lngY = lngY + 1 'lngy + 1
                
x = x + 1
End If
Next y
End Sub

Ist sicher nicht die eleganteste Lösung und ich habe deinen Code jetzt auch nicht ausprobiert. Ich habe einfach mal wieder den Makro-Recorder zuhilfe genommen ;)
Aber danke für's drüber schauen. Ich bin hier im Forum echt noch nie enttäuscht worden.
Traumhaft!
Beste Grüße
Easy

Bild

Betrifft: Danke für die Rückmeldung, owT
von: Michael
Geschrieben am: 01.12.2015 21:18:51


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Kopieren von Formeln mit Bedingung"