Herbers Excel-Forum - das Archiv

Wer kann mir helfen ein VBA Script zu ändern?

Bild

Betrifft: Wer kann mir helfen ein VBA Script zu ändern?
von: Darkman

Geschrieben am: 14.02.2005 13:53:43
Hallo,
Ich habe ein großes Problem mit einem VBA Script.
Ich habe diesen Script vor einiger Zeit zur Verfügung gestellt bekommen.
Dabei handelt es sich um einen Wochenarbeitsplan welcher die Arbeiten auf die Tage einer Woche verteilt.
Der script ist so geschrieben, das er wenn einen Arbeit länger als einen Arbeitstag dauert automatisch einen neuen Vorgang für den nächsten tag macht. es handelt sich hirbei um eine Excel Tabelle mit intgriertm VBA Script.
Wer kann mir helfen das der Überschlag auf den nächsten tag nicht wie bisher nach 8,25 Stunden erfolgt, sondern schon nach 7,5 Stunden???
Bin für jede Hilfe dankbar...
Das Beispile zeigt die Rohdaten welche aus SAP herausgeholt werden bevor das Makro ausgeführt wird.
Hier das Beispiel:

Die Datei https://www.herber.de/bbs/user/18039.xls wurde aus Datenschutzgründen gelöscht

Wer mir helfen möchte kann das Excel Sheet mit dem VBA Script auch gerne per Mail geschickt bekommen.
Meinen E-Mail ist
juergen.dauer@arcor.de
Vielen Dank schon mal...
Bild

Betrifft: AW: Wer kann mir helfen ein VBA Script zu ändern?
von: NIke
Geschrieben am: 14.02.2005 14:11:04
Hi,
du kannst das VB Script auch einfach hier posten,
ich nehme stark an, man muss nur an einer Ecke schrauben ;-)
Bye
Nike
Bild

Betrifft: AW: Wer kann mir helfen ein VBA Script zu ändern?
von: Darkman

Geschrieben am: 14.02.2005 14:17:07
OK dann ist hier das Script...
Es reicht allerdings nicht die Zeile if Arbeitvorrat> 8.25 Then.. zu ändern das habe ich schon probiert.
Vielen Dank schon mal...
Option Explicit
Sub Arbeitsplan()
Dim lZeile
Dim lSpalte
Dim i
Dim Arbeitsvorrat
Dim Startzeit
Dim Endzeit
Dim Tagesstunden
Dim bstartZeile As Boolean
Dim rowCount As Integer
Cells(1, 7).EntireColumn.Insert     'Spalte Tagesstunden einfügen
Cells(1, 7) = "Tagesstunden"
Cells(1, 17).EntireColumn.Insert     'Spalte Kennzeichen einfügen
Cells(1, 17) = "Kennzeichen"
lZeile = Cells(65000, 1).End(xlUp).Row
lSpalte = Cells(1, 200).End(xlToLeft).Column
For i = 2 To lZeile
DoEvents
Cells(i, 2) = TimeValue(Cells(i, 2)) * 24
Cells(i, 4) = TimeValue(Cells(i, 4)) * 24
Cells(i, 8) = Cells(i, 8) / Cells(i, 10)
Next i
i = 2
bstartZeile = True
Do While i <= lZeile
DoEvents
Arbeitsvorrat = Cells(i, 8)
If bstartZeile = True Then                  '****** 1. Zeile *****
rowCount = i + 1
If Arbeitsvorrat > (15 - Cells(i, 2)) Then
Cells(rowCount, 1).EntireRow.Insert
Range(Cells(i, 1), Cells(i, lSpalte)).Copy
Range(Cells(rowCount, 1), Cells(rowCount, lSpalte)).PasteSpecial xlValues
Application.CutCopyMode = False
Cells(rowCount, 3) = Cells(rowCount, 1)       'Enddatum = Startdatum
Cells(i, 17) = "O"
Startzeit = Cells(rowCount, 2)
If Arbeitsvorrat > 8.25 Then
If Startzeit + Arbeitsvorrat > 15 Then
Endzeit = Startzeit + Arbeitsvorrat
Arbeitsvorrat = Endzeit - 15
Cells(rowCount, 8) = Arbeitsvorrat
Endzeit = 15
Cells(rowCount, 4) = Endzeit
Tagesstunden = Endzeit - Startzeit
Cells(rowCount, 7) = Tagesstunden
Else
Endzeit = Startzeit + Arbeitsvorrat
Cells(rowCount, 4) = Endzeit
Tagesstunden = Endzeit - Startzeit
Cells(rowCount, 7) = Tagesstunden
Arbeitsvorrat = Arbeitsvorrat - Tagesstunden
End If
Else
If Startzeit + Arbeitsvorrat > 15 Then
Endzeit = Startzeit + Arbeitsvorrat
Arbeitsvorrat = Endzeit - 15
Cells(rowCount, 8) = Arbeitsvorrat
Endzeit = 15
Cells(rowCount, 4) = Endzeit
Tagesstunden = Endzeit - Startzeit
Cells(rowCount, 7) = Tagesstunden
Else
Endzeit = Startzeit + Arbeitsvorrat
Cells(rowCount, 4) = Endzeit
Tagesstunden = Endzeit - Startzeit
Cells(rowCount, 7) = Tagesstunden
Arbeitsvorrat = Arbeitsvorrat - Tagesstunden
End If
End If
If Arbeitsvorrat = 0 Then
bstartZeile = True
Else
bstartZeile = False
End If
Cells(rowCount, 8) = Arbeitsvorrat
Else
End If
lZeile = Cells(65000, 1).End(xlUp).Row
Else                                        '***** restliche Zeilen ******
rowCount = i + 1
Do While Arbeitsvorrat > 0
DoEvents
Cells(rowCount, 1).EntireRow.Insert
Range(Cells(rowCount - 1, 1), Cells(rowCount - 1, lSpalte)).Copy
Range(Cells(rowCount, 1), Cells(rowCount, lSpalte)).PasteSpecial xlValues
Application.CutCopyMode = False
If Weekday(Cells(rowCount, 1), 2) = 5 Then
Cells(rowCount, 1) = Cells(rowCount, 1) + 3 'Wochenende überspringen
Else: Cells(rowCount, 1) = Cells(rowCount, 1) + 1 'Datum ein Tag weiterzählen
End If
Startzeit = 6.75
Cells(rowCount, 2) = Startzeit
Cells(rowCount, 3) = Cells(rowCount, 1)       'Enddatum = Startdatum
If Arbeitsvorrat > 6 Then
Endzeit = 15
Cells(rowCount, 4) = Endzeit
Else
Endzeit = Startzeit + Arbeitsvorrat
Cells(rowCount, 4) = Endzeit
End If
Tagesstunden = Endzeit - Startzeit
Cells(rowCount, 7) = Tagesstunden
Arbeitsvorrat = Arbeitsvorrat - Tagesstunden
Cells(rowCount, 8) = Arbeitsvorrat
rowCount = rowCount + 1
If Arbeitsvorrat = 0 Then
bstartZeile = True
i = rowCount - 1
Else
bstartZeile = False
End If
Loop
lZeile = Cells(65000, 1).End(xlUp).Row
End If
If i > lZeile Then
i = lZeile
Else
i = i + 1
End If
Loop
lZeile = Cells(65000, 1).End(xlUp).Row
Range(Cells(2, 2), Cells(lZeile, 2)).NumberFormat = "#,##0.00"
Range(Cells(2, 4), Cells(lZeile, 4)).NumberFormat = "#,##0.00"
Range(Cells(2, 7), Cells(lZeile, 7)).NumberFormat = "#,##0.00"
Range(Cells(2, 8), Cells(lZeile, 8)).NumberFormat = "#,##0.00"
For i = 2 To lZeile
DoEvents
Cells(i, 2) = Cells(i, 2) / 24
Cells(i, 2).NumberFormat = "hh:mm"
Cells(i, 4) = Cells(i, 4) / 24
Cells(i, 4).NumberFormat = "hh:mm"
Next i
lZeile = Cells(65000, 1).End(xlUp).Row
lSpalte = Cells(1, 200).End(xlToLeft).Column
Cells(1, 18).EntireColumn.Insert     'Spalte Kennzeichen einfügen
Cells(1, 18) = "CATS-Stunden"
For i = 2 To lZeile
DoEvents
If Cells(i, 7) > 0 Then
Cells(i, 18) = Cells(i, 7) * Cells(i, 10)
Else
Cells(i, 18) = Cells(i, 8) * Cells(i, 10)
End If
Next i
lZeile = Cells(65000, 1).End(xlUp).Row
lSpalte = Cells(1, 200).End(xlToLeft).Column
Columns("H:H").Select
Selection.Copy
Columns("R:R").Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
Columns("R:R").Select                    'überflüssige Spalten löschen
Selection.Cut
Columns("H:H").Select
Selection.Insert Shift:=xlToRight
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Delete Shift:=xlToLeft
Columns("C:C").Select
Selection.Delete Shift:=xlToLeft
Columns("G:G").Select
Selection.Delete Shift:=xlToLeft
Columns("H:H").Select
Selection.Cut
Columns("E:E").Select
Selection.Insert Shift:=xlToRight
Columns("A:N").Select                        'Sortierung
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
lZeile = Cells(65000, 1).End(xlUp).Row
lSpalte = Cells(1, 200).End(xlToLeft).Column
Cells(1, 1).EntireColumn.Insert     'Spalte Wochentag einfügen
Cells(1, 1) = "Tag"
Range("B1").Select
Selection.Copy
Range("A1").Select
Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False
For i = 2 To lZeile                             'Wochentage berechnen
DoEvents
If Weekday(Cells(i, 2), 2) = 1 Then
Cells(i, 1) = "Montag"
Else
If Weekday(Cells(i, 2), 2) = 2 Then
Cells(i, 1) = "Dienstag"
Else
If Weekday(Cells(i, 2), 2) = 3 Then
Cells(i, 1) = "Mittwoch"
Else
If Weekday(Cells(i, 2), 2) = 4 Then
Cells(i, 1) = "Donnerstag"
Else
If Weekday(Cells(i, 2), 2) = 5 Then
Cells(i, 1) = "Freitag"
Else
If Weekday(Cells(i, 2), 2) = 6 Then
Cells(i, 1) = "Samstag"
Else
If Weekday(Cells(i, 2), 2) = 7 Then
Cells(i, 1) = "Sonntag"
End If
End If
End If
End If
End If
End If
End If
Next i
Range("A1").Select                              'Rasterformat einrichten
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Range("A1").Select                             'Summenzeilen ausblenden
Range(Selection, Selection.End(xlToRight)).Select
Selection.AutoFilter
Selection.AutoFilter Field:=15, Criteria1:="="
Range("A1").Select
Columns("A:P").Select
Columns("A:P").EntireColumn.AutoFit
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Font.Bold = True
End Sub

Bild

Betrifft: AW: Wer kann mir helfen ein VBA Script zu ändern?
von: UweD

Geschrieben am: 14.02.2005 14:16:29
Hallo

ohne jetzt das ganze Makro zu studieren...

8.25 kommt nur an einer Stelle vor..
Startzeit = Cells(rowCount, 2)
If Arbeitsvorrat > 8.25 Then
If Startzeit + Arbeitsvorrat > 15 Then
Endzeit = Startzeit + Arbeitsvorrat

Dann müsste dort deine Änderung rein.

Gruß UweD
Bild

Betrifft: AW: Wer kann mir helfen ein VBA Script zu ändern?
von: Peter Feustel
Geschrieben am: 14.02.2005 14:21:40
Hallo Darkmann,
die einzige Stelle, in der 8.25 vorkam, habe ich in 7.5 geändert.
Versuch es also damit mal.
Gruß Peter
https://www.herber.de/bbs/user/18043.xls
Bild

Betrifft: Nur so haut's hin
von: EtoPHG

Geschrieben am: 14.02.2005 14:48:08
Hallo Darkman oder Jürgen ?
Hier ist deine Mappe mit geändertem Code.
Die 8.25 errechnen sich aus der Startzeit und der Endzeit.
Da diese als fixe Konstanten im Script standen funktioniert alles obige schlecht oder nicht.
Ich hab sie an den Anfang des Codes gestellt, wo sie einfacher geändert werden können.
https://www.herber.de/bbs/user/18046.xls

Gruss Hansueli
Bild

Betrifft: AW: Nur so haut's hin
von: Darkman

Geschrieben am: 14.02.2005 15:42:30
Hallo Hansueli
super das funktioniert!!!
Vielen vielen Dank für den Script.
Muß der Script eigentlich so groß sein für die paar Aktionen die ausgeführt werden
(Wochentage einfügen, einige Spalten loschen, Autofilter setzen, überschlag auf neuen Tag bei Arbeit größer 7,5 Stunden)
Ich habe ja nicht wirklich Ahnung davon,aber ein Script von vier seiten dafür finde ich doch sehr sehr viel.
Nochmal vielen Dank an dich und alle die mir so schnell geholfen habe.
Da wird sich mein Chef morgen feuen... ;-)
Grüsse
Jürgen
Bild

Betrifft: AW: Nur so haut's hin
von: EtoPHG

Geschrieben am: 14.02.2005 15:52:26
Hallo Jürgen,
Freut mich, das es funktioniert. Ob der Script so gross sein muss ?
Keine Ahnung, ich hatte zu wenig Zeit um ihn genau zu analysieren.
Aber da "alle Wege nach Rom führen" gibt es vermutlich schon Verbesserungspotential.
Allerdings gilt auch der Satz "Never touch a running system..."
Gruss Hansueli
 Bild
Excel-Beispiele zum Thema "Wer kann mir helfen ein VBA Script zu ändern?"
VBScript mit Parameter aus VBA aufrufen Aufruf eines VBScripts aus VBA
Webabfrage über ein Perl-Script