Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Kopieren von Formeln mit Bedingung

Forumthread: Kopieren von Formeln mit Bedingung

Kopieren von Formeln mit Bedingung
29.11.2015 15:14:11
EasyD

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

Anzeige

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
ungetestet
29.11.2015 18:00:20
Michael
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.

Anzeige
Nachtrag
29.11.2015 18:10:14
Michael
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

Anzeige
AW: Nachtrag
01.12.2015 21:07:28
EasyD
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

Anzeige
Danke für die Rückmeldung, owT
01.12.2015 21:18:51
Michael

;

Forumthreads zu verwandten Themen

Anzeige
Anzeige
Anzeige
Anzeige
Entdecke relevante Threads

Schau dir verwandte Threads basierend auf dem aktuellen Thema an

Alle relevanten Threads mit Inhaltsvorschau entdecken

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige