AW: Hilfe zu einem Projektplan
20.01.2019 17:04:24
Piet
Hallo Alexander
anbei erst mal ein korrigierte Makro, bitte ins Modul kopieren. Den Auswertefehler habe ich hoffentlich gefunden, und die MsgBox für Samstag direkt mit eingebaut.Ich prüfe jetzt auch ob in der Zelle bereits ein Wert vorliegt, dann erfolgt Abbruch mit der Bitte das selbst zu prüfen.
Die Frage einer Verzugsauswertung laesst sich überlegen. Woran erkenne ich das? Du hast darin mehr Erfahrung.
mfg Piet
Option Explicit '20.1.2019 Piet für Herber Forum
Const PlanSheet = "Tabelle1" 'Hier Name des Plan Sheet angeben
Const FS = 6 'Frühschicht: Uhrzeit als glatte Zahl angeben!
'Makro zum Planungs Zeiten auflisten
Sub ProduktCode_übertragen()
Dim lSpa As Long, spa As Long, ok
Dim Datum As Date, Produkt As String
Dim Felder As Integer, Feld1 As Integer
Dim i As Long, j As Long, Zeile As Long
Dim Schicht As Variant, Schfla As String
'Name des gedrückten Buttons
Schfla = Application.Caller
With Worksheets(PlanSheet) '** "Tabelle1"
'Zeile des aufrufenden Button ermitteln
Zeile = .Shapes(Schfla).TopLeftCell.Row
lSpa = .Cells(4, Columns.Count).End(xlToLeft).Column
'Button Zeile Prüfung ob die "Start" Zelle gefunden wird!
If Cells(Zeile, 5).Value "Start" Then
MsgBox Schfla & " - TopLeftCell ist die Zeile: " & Zeile & Chr(10) & _
"Dieser Button sitzt nicht richtig, kann die 'Start' Zelle nicht finden!"
Exit Sub
End If
'Schichtzeit ermitteln
Produkt = Cells(Zeile + 1, 11) 'Produkt Name
Schicht = Hour(Right(Cells(Zeile + 1, 5), 8))
Datum = CDate(Left(Cells(Zeile + 1, 5), 10))
Felder = WorksheetFunction.RoundUp(Cells(Zeile + 1, 6), 0)
Feld1 = Zeile + 1 'Frühschicht setzen
'Start auf korrekte Schicht einstellen NS, FS, SS
If Schicht >= FS + 8 Then Feld1 = Zeile + 2
If Schicht >= FS + 16 Or Schicht lSpa Then MsgBox Datum & " kann Start Datum nicht finden!!": Exit Sub
'Datum Spalte als Variable laden
spa = Cells(4, i).Column
'Produkt in Tabelle eintragen (alle Spalten)
For j = 1 To Int(Felder / 3) + 1
'Produkt in akt. Spalte eintragen
For i = Feld1 To Zeile + 2
If Cells(i, spa) "" Then GoTo Fehler
Cells(i, spa) = Produkt
Felder = Felder - 1
If Felder = 0 Then GoTo Ende
Next i
'Feld1 auf Zeile setzen, Next Spalte
Feld1 = Zeile: spa = spa + 2
If Cells(3, spa) = "SA" Then
Datum = CDate(Left(Cells(4, spa), 10))
ok = MsgBox("Produktion " & Datum & " auf Montag verlegen?", vbYesNo)
If ok = vbYes Then spa = spa + 2
End If
Next j
Ende: Exit Sub 'Programm Ende
End With
Fehler: Cells(i, spa).Select
MsgBox "Die markierte Zelle enthaelt bereits einen Wert - bitte prüfen!"
End Sub