AW: Produktionsplanung_Rüstmatrix 2
07.12.2016 18:43:16
Michael
Hi,
mit einer weiteren Variablen und Inputbox:
Sub ruestzeit()
Const ArtiQuell = "A4", ArtiZiel = "A4", Ruest = "B4", az_Ziel = "C6"
'hier jeweils die linke, obere Ecke der Bereiche mit Daten
Const shQuell = "Tabelle1", shRuest = "Tabelle2", shZiel = "Tabelle3"
' hier die Namen der Blätter ändern, falls sie umbenannt werden...
Dim aq, az, r
Dim s&, z&, w#, l&
Dim letzter As Range
Dim IBerg$ ' InputBoxErgebnis as string
' statt l = 3
On Error Resume Next
Set letzter = Application.InputBox("Was wurde zuletzt hergestellt?", "Artikel anklicken", Type:= _
8)
On Error GoTo 0
If letzter Is Nothing Then Exit Sub ' falls abgebrochen wurde
If letzter.Count > 1 Then MsgBox ("Bitte nur 1 Zelle wählen"): Exit Sub
' letzter hat jetzt den Datentyp "range"
' wir benötigen die Nr. der Zeile innerhalb des Arrays r, das unten eingelesen wird.
' das ist, weil die Rüstmatrix nur noch eine Zeile Überschrift enthält, eines weniger
' als im Produktionsplan alt
' Der Produktionsplan alt beginnt wie oben definiert bei ArtiQuell = "A4"
l = letzter.Row - Range(ArtiQuell).Row + 1
MsgBox l ' die kannste dann wieder löschen
Sheets(shZiel).Cells.Clear ' alles löschen, falls mehr Zeilen vorhanden als beim
'neuen Kopieren
Sheets(shQuell).Range(ArtiQuell).CurrentRegion.Copy Sheets(shZiel).Range(ArtiZiel)
' dabei wird das NEU in Produktionsplan überschrieben; wenn Du willst, kannst Du
' das wieder einfügen:
Sheets(shZiel).Range(ArtiZiel).Value = "Produktionsplan NEU"
aq = Sheets(shQuell).Range(ArtiQuell).CurrentRegion
r = Sheets(shRuest).Range(Ruest).CurrentRegion
' Plausibilitätstest Anfang ****
MsgBox "Das ist der gewählte Artikel: " & r(l - 1, 1) ' ist ok, kannst auch löschen
Sheets(shZiel).Range("C2").Value = "Vorhergehende Produktion: " & r(l - 1, 1)
'aber es ist doch ganz nützlich, wenn das in der Tabelle3 steht
'Man könnte diese Ausgabe noch abhängig machen vom Werte in ArtiZiel = "A4"
If UBound(aq) UBound(r) + 1 Then MsgBox "Zeilen passen nicht": Exit Sub
' in Deiner ersten Datei hatte die Rüstmatrix ZWEI Zeilen Überschriften,
' in der neuen nur noch eine - macht nichts, aber deshalb das +1
If UBound(aq) UBound(r, 2) Then MsgBox "Zeilen Überschrift RM": Exit Sub
' jetzt werden die Artikel (A, B...) im Pp Alt mit den Überschriften der Rüstmatrix
' verglichen
For z = 3 To UBound(aq)
If aq(z, 1) r(z - 1, 1) Or aq(z, 1) r(1, z) Then MsgBox "paßt nicht": Exit Sub
' hier erfolgen beide Prüfungen nach Übereinstimmung in einem Rutsch mit "Or"
Next
' Plausibilitätstest Ende ****
ReDim az(1 To UBound(aq) - 2, 1 To UBound(aq, 2) - 2)
For s = 3 To UBound(aq, 2)
For z = 3 To UBound(aq)
If aq(z, s) "" Then
If z = l Then
az(z - 2, s - 2) = aq(z, s)
Else
w = r(z - 1, l) * r(z - 1, 2) ' jetz z-1, weil r nur 1 Überschriftenzeile hat
IBerg = InputBox("Produktionswert " & aq(z, s) & vbLf & _
"Rüstzeit " & r(l - 1, 1) & " " & r(z - 1, 1) & " = " & r(z - 1, l) & " * _
" _
& r(z - 1, 2) & " = " & w & vbLf & "Rest (Differenz) = " & aq(z, s) - w, _
Default:=CStr(aq(z, s) - w))
If IBerg = "" Then az(z - 2, s - 2) = aq(z, s) - w Else az(z - 2, s - 2) = Val(IBerg) _
l = z
End If
End If
Next
Next
Sheets(shZiel).Range(az_Ziel).Resize(UBound(az), UBound(az, 2)) = az
End Sub
Man könnte das noch mit einem If garnieren, so daß die Input-Box nur dann erscheint, wenn ein Wert kleiner 0 (oder irgendwas) erscheint.
Schöne Grüße,
Michael
P.S.: Der sinnvollere Weg wäre wahrscheinlich, die "große" Tabelle statt mit Formeln mit einem vernünftigen VBA-Skript auszuwerten. Aber das artet in einen Programmierauftrag aus...