Hallo Ronny,
dass deine If-Prüfungen nicht funktionieren liegt daran, dass die Zellen nicht leer sind. In den Zellen steht jeweils "(Leer)", das du durch die bedingte Formatierung "unsichbar" gemacht hast.
Ich hab deine Wünsche nochmals eingearbeitet. Dabei waren insbesondere an der Rp2-Prozedur grundlegende Änderungen nötig, um zu berücksichtigen, dass in der Rp1-Prozedur alle Stromnummern weggelassen werden, für die keine Werte in den Spalten G, H und I eingetragen sind.
Deshalb hier nochmals die komplett überarbeiteten Prozeduren.
Ich hoffe, dass ich bei den verschiedenen If-Abfragen alle Sonderfälle getroffen hab und die Prozeduren ohne Debug-Abbruch durchlaufen.
Gruß
Franz
Private Sub als_Rp1_festlegen_Click()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim SpalteZiel As Integer, ZeileQuelle As Long, rngBereich As Range
Dim I As Long, Pruefung As Boolean
Set wksQuelle = Me 'Worksheets("Bilanz Messwerte")
Set wksZiel = Worksheets("Rp-Vergleich")
ZeileQuelle = 8 '1. Zeile in Quelle mit Daten
SpalteZiel = 5 ' Spalte E, 1. auszufüllende Spalte in Zieltabelle
With wksQuelle
'Belegte Zeilen in Spalte A
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Rows.Count, "A").End(xlUp))
Eingabe: 'RpBemerkung Abfragen
Rp1Bemerkung = InputBox("Bitte geben Sie eine kurze Bezeichnung des Referenzpunktes 1 ein!", _
"Referenzpunkt (Rp1) benennen ")
wksZiel.Cells(8, "F") = Rp1Bemerkung 'RpBemerkung eintragen
'StromNr. Abfragen
Eingabe2:
StoffStrom = Val(InputBox("Bitte geben Sie die StromNr. Ihrer gewünschten Hauptgröße ein!", _
"Hauptgröße definieren durch Eingabe der StromNr."))
If StoffStrom = 0 Then Exit Sub 'Abbrechen geklickt oder nichts eingegeben
Pruefung = False
For I = 1 To rngBereich.Rows.Count
If rngBereich(I, 1) = StoffStrom Then Pruefung = True: Exit For
Next
If Pruefung = False Then
MsgBox "Es wurde keine gültige StromNr. angegeben!" & vbLf & vbLf _
& "Bitte geben Sie eine gültige StromNr. des Systems an!", vbCritical
On Error GoTo 0
GoTo Eingabe2
End If
Call getMoreSpeed(True)
'Altdaten im Ziel löschen
wksZiel.Range(wksZiel.Cells(13, "E"), wksZiel.Cells(19, wksZiel.Columns.Count)).ClearContents
'Datum übertragen
wksZiel.Cells(8, "C") = .Cells(4, "K")
wksZiel.Cells(19, "C") = .Cells(4, "K")
'Bereich mit Daten in Quelltabelle
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "I"))
'Hauptstrom eintragen
'Abfrage ob 1.Normalbet., 2.Infra- od. 3.Laborwert vorhanden ist und wenn ja dann erst 1., dann 2. und als letztes 3. einsetzen
'Zeile 8 in Zieltabelle ausfüllen
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 9, False) <> "(Leer)" Then
'Normalbetrieb
wksZiel.Cells(2, "F") = "Normalbetrieb"
wksZiel.Cells(8, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 9, False)
Else
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 7, False) <> "(Leer)" Then
'Infra-Wert
wksZiel.Cells(2, "F") = "Infrawert"
wksZiel.Cells(8, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 7, False)
Else
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 8, False) <> "(Leer)" Then
'LaborWert
wksZiel.Cells(2, "F") = "Laborwert"
wksZiel.Cells(8, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 8, False)
Else
If MsgBox("Es ist für den gewählten Strom kein Eintrag in den Spalten Betrieb, Infrawert oder Laborwert vorhanden!", _
vbOKCancel, "Rp1 Hauptstrom-Daten übertragen") = vbCancel Then
Exit Sub
End If
End If
End If
End If
wksZiel.Cells(3, "E") = StoffStrom
wksZiel.Cells(7, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 2, False)
wksZiel.Cells(5, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 3, False)
wksZiel.Cells(4, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 4, False)
wksZiel.Cells(6, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 5, False)
'Daten Stoffströme übertragen
Do Until IsEmpty(.Cells(ZeileQuelle, "A")) And IsEmpty(.Cells(ZeileQuelle, "K"))
If Not IsEmpty(.Cells(ZeileQuelle, "A")) And StoffStrom <> .Cells(ZeileQuelle, "A") Then
'Abfrage ob 1.Normalbet., 2.Infra- od. 3.Laborwert vorhanden ist und wenn ja dann erst 1., dann 2. und als letztes 3. einsetzen
'Zeile 19 in Zieltabelle ausfüllen
If .Cells(ZeileQuelle, "I") <> "(Leer)" Then
'Normalbetrieb
wksZiel.Cells(13, SpalteZiel) = "Normalbetrieb"
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "I")
Else
If .Cells(ZeileQuelle, "G") <> "(Leer)" Then
'Infra-Wert
wksZiel.Cells(13, SpalteZiel) = "Infrawert"
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "G")
Else
If .Cells(ZeileQuelle, "H") <> "(Leer)" Then
'LaborWert
wksZiel.Cells(13, SpalteZiel) = "Laborwert"
wksZiel.Cells(19, SpalteZiel) = .Cells(ZeileQuelle, "H")
Else
'kein Eintrag in den Spalten I, G oder H --> Zeile überspringen
ZeileQuelle = ZeileQuelle + 1
GoTo NaechsteZeile
End If
End If
End If
wksZiel.Cells(14, SpalteZiel) = .Cells(ZeileQuelle, "A")
wksZiel.Cells(18, SpalteZiel) = .Cells(ZeileQuelle, "B")
wksZiel.Cells(16, SpalteZiel) = .Cells(ZeileQuelle, "C")
wksZiel.Cells(15, SpalteZiel) = .Cells(ZeileQuelle, "D")
wksZiel.Cells(17, SpalteZiel) = .Cells(ZeileQuelle, "E")
ZeileQuelle = ZeileQuelle + 1
SpalteZiel = SpalteZiel + 1
If SpalteZiel = wksZiel.Columns.Count + 1 Then
MsgBox "Es können max. " & wksZiel.Columns.Count & " Spalten ausgefüllt werden."
Exit Sub
End If
Else
'2. Zeile eines Stoffstroms mit mehreren Grenzwerten, dann do nothing?
ZeileQuelle = ZeileQuelle + 1
End If
NaechsteZeile:
Loop
End With
Call getMoreSpeed(False)
'Erfolgsmeldung und Abfrage ob zu Rp-Vergleich gewechselt werden soll
Dim a As String
a = MsgBox("Wollen Sie die Messdaten für Referenzpunkt 1 jetzt überprüfen?", vbYesNo, "Kopiervorgang der Rp1-Messdaten erfolgreich")
If a = vbNo Then
Worksheets("Bilanz Messwerte").Select
Else
Worksheets("Rp-Vergleich").Select
End If
End Sub
Private Sub als_Rp2_festlegen_Click()
Dim wksQuelle As Worksheet, wksZiel As Worksheet
Dim SpalteZiel As Integer, ZeileQuelle As Long, rngBereich As Range
Dim I As Long, Pruefung As Boolean
Set wksQuelle = Me 'Worksheets("Bilanz Messwerte")
Set wksZiel = Worksheets("Rp-Vergleich")
ZeileQuelle = 8 '1. Zeile in Quelle mit Daten
SpalteZiel = 5 ' Spalte E, 1. auszufüllende Spalte in Zieltabelle
With wksQuelle
Eingabe: 'RpBemerkung Abfragen
Rp2Bemerkung = InputBox("Bitte geben Sie eine kurze Bezeichnung des Referenzpunktes 2 ein!", _
"Referenzpunkt (Rp2) benennen ")
wksZiel.Cells(9, "F") = Rp2Bemerkung 'RpBemerkung eintragen
Call getMoreSpeed(True)
'StromNr. übernehmen, welche bei Rp1 schon festgelegt wurde
StoffStrom = wksZiel.Cells(3, "E")
'Datum übertragen
wksZiel.Cells(9, "C") = .Cells(4, "K")
wksZiel.Cells(20, "C") = .Cells(4, "K")
'Bereich mit Daten in Quelltabelle
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "I"))
'Altdaten im Ziel löschen
wksZiel.Range(wksZiel.Cells(20, "E"), wksZiel.Cells(20, wksZiel.Columns.Count)).ClearContents
wksZiel.Range(wksZiel.Cells(23, "E"), wksZiel.Cells(23, wksZiel.Columns.Count)).ClearContents
'Hauptstrom eintragen
'Abfrage ob 1.Normalbet., 2.Infra- od. 3.Laborwert vorhanden ist und wenn ja dann erst 1., dann 2. und als letztes 3. einsetzen
'Zeile 9 in Zieltabelle ausfüllen
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 9, False) <> "(Leer)" Then
'Normalbetrieb
wksZiel.Cells(10, "F") = "Normalbetrieb"
wksZiel.Cells(9, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 9, False)
Else
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 7, False) <> "(Leer)" Then
'Infra-Wert
wksZiel.Cells(10, "F") = "Infrawert"
wksZiel.Cells(9, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 7, False)
Else
If Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 8, False) <> "(Leer)" Then
'LaborWert
wksZiel.Cells(10, "F") = "Laborwert"
wksZiel.Cells(9, "E") = Application.WorksheetFunction.VLookup(StoffStrom, rngBereich, 8, False)
Else
If MsgBox("Es ist für den gewählten Strom kein Eintrag in den Spalten Betrieb, Infrawert oder Laborwert vorhanden!", _
vbOKCancel, "Rp2 Hauptstrom-Daten übertragen") = vbCancel Then
Exit Sub
End If
End If
End If
End If
'Rp2-Daten für StoffstromNummern aus Rp1-Eintrag in Zieltabelle einlesen
Do Until IsEmpty(wksZiel.Cells(14, SpalteZiel))
'Prüfen ob die StromNummer in der Quelle vorhanden ist
'Bereich mit Stromnummern in Spalte A
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Rows.Count, "A").End(xlUp))
Pruefung = False
For I = 1 To rngBereich.Rows.Count
If rngBereich(I, 1) = wksZiel.Cells(14, SpalteZiel) Then Pruefung = True: Exit For
Next
If Pruefung = False Then
'StromNummer nicht vorhanden
wksZiel.Cells(23, SpalteZiel) = "Keine StromNr"
wksZiel.Cells(20, SpalteZiel) = "Keine StromNr"
Else
'Abfrage ob 1.Normalbet., 2.Infra- od. 3.Laborwert vorhanden ist und wenn ja dann erst 1., dann 2. und als letztes 3. einsetzen
'Zeile 20 in Zieltabelle ausfüllen, in Spalte 23 wird eingetragen wo Wert herkommt
'Bereich mit Daten in Quelltabelle
Set rngBereich = .Range(.Cells(ZeileQuelle, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "I"))
If Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 9, False) <> "(Leer)" Then
'Normalbetrieb
wksZiel.Cells(23, SpalteZiel) = "Normalbetrieb"
wksZiel.Cells(20, SpalteZiel) = Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 9, False)
Else
If Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 7, False) <> "(Leer)" Then
'Infra-Wert
wksZiel.Cells(23, SpalteZiel) = "Infrawert"
wksZiel.Cells(20, SpalteZiel) = Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 7, False)
Else
If Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 8, False) <> "(Leer)" Then
'LaborWert
wksZiel.Cells(23, SpalteZiel) = "Laborwert"
wksZiel.Cells(20, SpalteZiel) = Application.WorksheetFunction.VLookup(wksZiel.Cells(14, SpalteZiel), rngBereich, 8, False)
Else
'kein Wert vorhanden
wksZiel.Cells(23, SpalteZiel) = "KeinWert"
wksZiel.Cells(20, SpalteZiel) = "KeinWert"
End If
End If
End If
End If
SpalteZiel = SpalteZiel + 1
If SpalteZiel = wksZiel.Columns.Count + 1 Then
MsgBox "Es können max. " & wksZiel.Columns.Count & " Spalten ausgefüllt werden."
Exit Do
End If
Loop
End With
Call getMoreSpeed(False)
'Erfolgsmeldung und Abfrage ob zu Rp-Vergleich gewechselt werden soll
Dim a As String
a = MsgBox("Wollen Sie die Messdaten für Referenzpunkt 2 jetzt überprüfen?", vbYesNo, "Kopiervorgang der Rp2-Messdaten erfolgreich")
If a = vbNo Then
Worksheets("Bilanz Messwerte").Select
Else
Worksheets("Rp-Vergleich").Select
End If
End Sub
Sub getMoreSpeed(bDoIt As Boolean)
Application.ScreenUpdating = Not (bDoIt)
Application.EnableEvents = Not (bDoIt)
Application.Calculation = IIf(bDoIt, xlCalculationManual, xlCalculationAutomatic)
End Sub