zwei Schlaufen mit bedingter Ausführung
Peter
Nachfolgender Code läuft, doch ich habe irgend ein strukturelles Problem. Ich trage in einem Bereich Werte ein.
Wenn in einer bestimmten Zelle nicht "JA" steht, darf kein Eintrag erfolgen, allfällige Einträge müssen in dieser Zeile gelöscht werden.
Mir ist nicht klar, wie ich vermeide, dass ich sowohl Then GoTo Weiter_MIT_LOESCHEN als auch Goto Weiter_OHNE_LOESCHEN brauche.
Wenn mir da jemand ein Tipp geben könnte, wäre das super.
Danke, Peter
Sub Eintragen()
Dim Bereich As Range, Feld As Range, qRngXX As Range
Dim QArea As Range, QCell As Range
Dim p$, f$, r$, n%, s$, m%, o%, z%, p_und_f$
Dim Anzahl$, ErsteZeile As Long, zNr As Long
Dim aktSheet$
aktSheet = ActiveSheet.Name
ErsteZeile = 5 'Erste Zeile in XXTab
n = Cells(65536, [RefZeile].Column).End(xlUp).Row
Set Bereich = Range(Cells(ErsteZeile, [XX01pfad].Column), Cells(n, [XX01pfad].Column))
Set qRngXX = Range("q_pf")
o = rErsteSpalte(qRngXX)
m = rLetzteSpalte(qRngXX)
z = [RefZeile].Row
Set QArea = Range(Cells(z, o), Cells(z, m))
Anzahl = 0
zNr = ErsteZeile
For Each Feld In Bereich
If UCase(Cells(zNr, [XX01PF_JA].Column)) "JA" Then GoTo Weiter_MIT_LOESCHEN
p = Cells(zNr, [XX01pfad].Column) & "\PF\" & [Jahr]
f = Cells(zNr, [XX01ak].Column) & "PF" & Right([Jahr], 2) & Right(aktSheet, 2) & ".xls" ' _
Filename
s = Cells(zNr, [XX01Klasse].Column) 'Worksheet
For Each QCell In QArea
r = QCell.Value
Cells(Feld.Row, QCell.Column) = getvalue(p, f, s, r)
Next
Anzahl = Anzahl + 1
GoTo Weiter_OHNE_LOESCHEN
Weiter_MIT_LOESCHEN:
Range(Cells(zNr, o), Cells(zNr, m)) = ""
Weiter_OHNE_LOESCHEN:
zNr = zNr + 1
Next
End Sub
Anzeige