ich benötige Hilfe für folgendes Makro. Es soll in Tabelle A die Spalte F durchlaufen und überprüfen, ob deren Wert >0 ist. Wenn ja sollen weitere Werte aus dieser Zeile, Zelle für Zelle in den Zielbereich der Tabelle B kopiert werden und anschliessend soll die Schleife in Tabelle A weiterlaufen, bis zum nächsten Wert >0 in Spalte F. Danach sollen in Tabelle B, in die darauffolgende Zeile die Werte eingefügt werden usw.
Nun funktioniert das Makro soweit, dass es in Tabelle A, die richtigen Zellen kopiert, aber ab der zweiten
Zeile in Tabelle B funk werden die Schleifen nicht korrekt durchlaufen.
Ich wäre sehr dankbar für Eure Hilfe, da ich leider nicht mehr weiterkomme.
Hier ist das Makro. Meine Bsp-Datei habe ich auch upgeloadet.
https://www.herber.de/bbs/user/47404.xls
Besten Dank im voraus für Eure Hilfe.
Sub KopiereAnachB()
'Hinweis Cells.Select Befehle habe ich eingefügt, um beim Debuggen eine visuelle Kontrolle zu _
haben
'Set Variables and Status Notice
Application.StatusBar = "Achtung! - Makro läuft"
Sheets("A").Select
Dim row As Range
Dim x As Integer
Dim xy As Integer
Dim rng As Range
Dim i As Integer, counter As Integer
Dim LetzteZeile As Integer
'Set the range to evaluate to rng. Innerhalb dieser Range wird geprüft, ob ein Wert >0 _
vorhanden ist.
Set rng = Range("F1:F156")
'initialize i to 1
i = 1
'Loop for a count of 1 to the number of rows
'in the range that you want to evaluate.
For counter = 1 To rng.Rows.Count
'Wenn die Zelle den Wert >0 hat Wert kopieren,
'sonst springe zur nächsten Zeile Werte i +1
extern:
i = i + 1
Sheets("A").Select
If rng.Cells(i) > "0" Then
rng.Cells(i, 1).Select
rng.Cells(i, 1).Copy
'Ermittele die nächste freie Zeile für den Bereich Zeile 28 bis 44
Set row = Range("A28:A44")
x = 28
For xy = 1 To row.Rows.Count
'Wenn im Zieltabellenblatt der Wert für die Zelle leer ist füge den Wert aus Tabelle A ein
'Diese Wenn-abfrage ist für den Zielbereich und kopiert die Werte von A nach B
'Nachdem die 5 Werte wie im folgenden kopiert werden, soll für den Zielbereich in Tabelle B
'der Zeilenzähler +1 erhöht werden.
If IsEmpty(row.Cells(x, 6)) = True Then
Sheets("B").Select
LetzteZeile = Cells(Cells.Rows.Count, 3).End(xlUp).row
With Sheets("B") 'Namen anpassen
.Cells(LetzteZeile + 1, 1) = Cells(x, 4).Select
.Paste
Sheets("A").Select
rng.Cells(i, 0).Select
rng.Cells(i, 0).Copy
Sheets("B").Select
LetzteZeile = Cells(Cells.Rows.Count, 3).End(xlUp).row
With Sheets("B") 'Namen anpassen
.Cells(LetzteZeile + 1, 1) = Cells(x, 5).Select
.Paste
Sheets("A").Select
rng.Cells(i, -2).Select
rng.Cells(i, -2).Copy
Sheets("B").Select
LetzteZeile = Cells(Cells.Rows.Count, 3).End(xlUp).row
With Sheets("B") 'Namen anpassen
.Cells(LetzteZeile + 1, 1) = Cells(x, 3).Select
.Paste
Sheets("A").Select
rng.Cells(i, -3).Select
rng.Cells(i, -3).Copy
Sheets("B").Select
LetzteZeile = Cells(Cells.Rows.Count, 3).End(xlUp).row
With Sheets("B") 'Namen anpassen
.Cells(LetzteZeile + 1, 1) = Cells(x, 2).Select
.Paste
Sheets("A").Select
rng.Cells(i, -4).Select
rng.Cells(i, -4).Copy
Sheets("B").Select
LetzteZeile = Cells(Cells.Rows.Count, 3).End(xlUp).row
With Sheets("B") 'Namen anpassen
.Cells(LetzteZeile + 1, 1) = Cells(x, 6).Select
.Paste
' x = row.Rows.Count
End With
End With
End With
End With
End With
'Werte wurden kopiert, nun erhöhe den Zeilenzähler +1 und gehe zur nächsten Schleife in Tabelle _
A
xy = xy + 1
x = x + 1
'Ab hier habe ich nun die Probleme, wenn das Makro die Schleife in Tabelle A für den Wert i _
beginnt und dann
'aufgrund der If-Bedingung in Tabelle B mit Wert x weiterläuft, springt die Schleife entweder _
nur noch im Zielbereich
'B weiter und dadurch läuft dann die Schleife in für A nicht mehr korrekt. Mit Goto habe konnte _
ich das Problem leider nicht lösen.
'GoTo extern
Else
x = x + 1
End If
Next
i = i + 1
Sheets("A").Select
Else
i = i + 1
End If
Next
Application.StatusBar = ""
End Sub
Viele Grüsse
Frank