Hallo nochmal,
Hier liefere ich den Code meiner Arbeitsmappe( besser Vorlage) ,aus dem meine Arbeitsmappe generiert wird.
Zum besseren Verständniss erkläre ich kurz meine 'Modul-Architektur':
1. Das Generator-Modul steuert den Generierungs-Prozess (diesen Code zeige ich auch hier)
2. Das Kalendar-Modul liefert mir die Feiertage und Wochenenden eines Monats(eigentlich nur Date- und Integer-Operationen)
3. Das FormelKonverter-Modul generiert mir die Formeln für die enstsprechende Zelle (eigentlich nur String-Operationen)
4. meine Vorlage enthält noch ein Formular welches zu Beginn gestartet wird und im Dialog Standartwerte vom User erhält und den Generator-Prozess anschiebt
5. Zwei Worksheets sind Standart-Mäßig enthalten, eines um die Standarteinstellungen zu speichern (verborgen) und eines um zur Laufzeit auf ständige Ereignisse zu reagieren (nicht groß)
6. Hier folgt der Code des Generator-Moduls, welches mit Abstand das größte ist:
Private dateStandartwerte(3) As Date
'--------------------------------------------------------------------------->
'Schnittstelle: wird nur vom OpenFormular gerufen
'
Public Sub startGeneration()
dateStandartwerte(0) = OpenFormular.getTime("Arbeitsbeginn")
dateStandartwerte(1) = OpenFormular.getTime("Arbeitsende")
dateStandartwerte(2) = OpenFormular.getTime("Pause_von")
dateStandartwerte(3) = OpenFormular.getTime("Pause_bis")
Call CreateSheets
End Sub
'-------------------------------------------------------------------------------------------------->
'[Schnittstelle]->wurde erst später zur Schnittstelle, durch Projekte
'liefert ein verbundens Range-Objekt
'diese Funktion ist Public, wiel sie bei der erzeugung der Projekte/Worksheet-Monat
'benötigt wird
'
Public Function mergeCells(ByVal objRangeStart As Range, _
intAnzahl As Integer, _
ByVal objWorksheet As Worksheet) As Range
Dim objRangeReturn As Range
With objWorksheet
Set objRangeReturn = .Range(.Cells(objRangeStart.Row, objRangeStart.Column), _
.Cells(objRangeStart.Row, (objRangeStart.Column + intAnzahl - 1)))
End With
objRangeReturn.mergeCells = True
Set mergeCells = objRangeReturn
Set objRangeReturn = Nothing
Set objRangeStart = Nothing
Set objWorksheet = Nothing
End Function
'---------------------------------------------------------------------------->
'Erste bearbeitung vom Mario Stockmann (12.2004)
'Weitere Bearbeitung durch Jan Winter (01.2005)
'Schnittstelle: des Generators (wird vom Workbook.open-Event gerufen)
'Es werden 12 Sheets an die bestehenden Sheets angefügt.
'Den input-Dialog ggf. über ein Formular gestallten.
'
Private Sub CreateSheets()
Dim strYear As String
' strYear = CStr(Year(Now)) 'später wird ein geprüftes Jahr von OpenFormular.getJahr geholt
strYear = CStr(Year(OpenFormular.getTime("Jahr")))
' dateStandartwerte(0) = CDate("8:00")
' dateStandartwerte(1) = CDate("16:30")
' dateStandartwerte(2) = CDate("12:00")
' dateStandartwerte(3) = CDate("12:30")
If strYear <> "" Then
' für alle 12 Monate Arbeitsblätter anlegen
For nCounter = 1 To 12
' Monat anlegen
Call CreateSheet(CDate("1." & CStr(nCounter) & "." & CStr(strYear)))
Next
End If
' MsgBox CStr(CDate("1." & CStr(5) & "." & CStr(strYear)))
' Call CreateSheet(CDate("1." & CStr(5) & "." & CStr(strYear)))
On Error GoTo EH:
Exit Sub
EH:
End Sub
'
Private Sub CreateSheet(dateFirstInMonth As Date)
On Error GoTo EH:
Dim objCurSheet As Excel.Worksheet
'ein neues Sheet wird erzeugt
ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count())
'eine Referenz auf das neue Sheet wird geholt
Set objCurSheet = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count())
objCurSheet.Name = Format(dateFirstInMonth, "mmmm") '{Januar, Februar, März,...}
Call Layout.setColumnWidth(objCurSheet, True)
Call createKopf(objCurSheet)
Call createMonatsTage(objCurSheet, dateFirstInMonth)
Call createSummenRow(objCurSheet)
Call createEventProcedure
Call Layout.fixiereKopfUndDatum(objCurSheet)
Call Layout.updateStandartwerte(dateStandartwerte(0), dateStandartwerte(1), dateStandartwerte(2), dateStandartwerte(3), CStr(Year(dateFirstInMonth)))
Call OpenFormular.addStatusLine("MONAT " + objCurSheet.Name + " wurde erstellt.")
Set objCurSheet = Nothing
Exit Sub
EH:
End Sub
'---------------------------------------------------------------------------->
'Erzeugt den Tabellen-Kopf in einem Übergebenen Sheet
'mögliche existierende Daten würden überschrieben werden
'Worksheet objWorksheet:= das zu editierende Worksheet
'
Private Sub createKopf(objWorksheet As Worksheet)
Dim objCurRange As Range
Dim intStartColumn, intEndColumn, intStartRow, intEndRow, _
intIndexColumn, intIndexRow As Integer
intStartColumn = 1
intEndColumn = 11
intStartRow = 1
intEndRow = 2
For intIndexRow = intStartRow To intEndRow
For intIndexColumn = intStartColumn To intEndColumn
Set objCurRange = objWorksheet.Cells(intIndexRow, intIndexColumn)
Select Case intIndexColumn
Case 1:
If intIndexRow = 1 Then
Set objCurRange = mergeCells(objCurRange, 3, objWorksheet)
objCurRange.Value = "Datum"
End If
Case 2:
If intIndexRow = 1 Then
'1.Zeile,2.Spalte leer
Else
'2.Zeile,2.Spalte leer
End If
Case 3:
If intIndexRow = 1 Then
'1.Zeile,3.Spalte leer
Else
objCurRange.Value = "Typ"
End If
Case 4:
If intIndexRow = 1 Then
Set objCurRange = mergeCells(objCurRange, 2, objWorksheet)
objCurRange.Value = "Arbeitszeit"
Else
objCurRange.Value = "Beginn"
End If
Case 5:
If intIndexRow = 1 Then
'1.Zeile,5.Spalte leer
Else
objCurRange.Value = "Ende"
End If
Case 6:
If intIndexRow = 1 Then
Set objCurRange = mergeCells(objCurRange, 2, objWorksheet)
objCurRange.Value = "Pause"
Else
objCurRange.Value = "von"
End If
Case 7:
If intIndexRow = 1 Then
'1.Zeile,7.Spalte leer, weil merged
Else
objCurRange.Value = "bis"
End If
Case 8:
If intIndexRow = 1 Then
Set objCurRange = mergeCells(objCurRange, 3, objWorksheet)
objCurRange.Value = "Auswertung"
Else
objCurRange.Value = "Ist"
End If
Case 9:
If intIndexRow = 1 Then
'1.Zeile,9.Spalte leer weil merged
Else
objCurRange.Value = "Soll"
End If
Case 10:
If intIndexRow = 1 Then
'1.Zeile,10.Spalte leer, weil merged
Else
objCurRange.Value = "Diff"
End If
Case 11:
If intIndexRow = 1 Then
objCurRange.Value = "Projekte"
Else
objCurRange.Value = "Summe"
End If
End Select
Call Layout.setLayout("Kopf", objCurRange, "komplett")
Next intIndexColumn
Next intIndexRow
Set objCurRange = Nothing
End Sub
'---------------------------------------------------------------------------->
'liefert die linke,nächste Celle als Range-Objekt (nur Horizontal)
'
Private Function getNextCell(objCurRange As Range, objWorksheet As Worksheet) As Range
Dim objRangeReturn As Range
Dim intColumn, intRow As Integer
intColumn = objCurRange.Column
intRow = objCurRange.Row
Set objRangeReturn = objWorksheet.Cells(intRow + 1, intColumn)
' MsgBox CStr(objRangeReturn.Row) + "," + CStr(objRangeReturn.Column)
Set getNextCell = objRangeReturn
Set objRangeReturn = Nothing
End Function
'----------------------------------------------------------------------------->
'
'
Private Sub createMonatsTage(objWorksheet As Worksheet, dateFirstInMonth As Date)
Dim intRowStart, intRowEnde, intColumnStart, intColumnEnde, _
intRowIndex, intColumnIndex As Integer
Dim boolWochenende, boolFeiertag As Boolean
Dim strWochentag, strFeiertag, strLayoutName As String
Dim dateTmp As Date
Dim objCurRange As Range
intRowStart = 3
' intRowEnde = intRowStart + Kalender.Monatstage(intMonat, _
' OpenFormular.getJahr())
intRowEnde = (intRowStart - 1) + Kalendar.Monatstage(CInt(Month(dateFirstInMonth)), _
CInt(Year(dateFirstInMonth)))
intColumnStart = 1
intColumnEnde = 11
dateTmp = dateFirstInMonth
' Für Jede Zeile über alle Zeilen
For intRowIndex = intRowStart To intRowEnde
'isWochenende setzt boolWochenende + strWochentag{Mo,Di,Mi,...}
boolWochenende = Kalendar.isWochenende(dateTmp)
boolFeiertag = Kalendar.isFeiertag(dateTmp, "SA", True)
' Für jede Spalte ber alle Spalten
For intColumnIndex = intColumnStart To intColumnEnde
Set objCurRange = objWorksheet.Cells(intRowIndex, intColumnIndex)
'Alle Spalten werden wie {Tag(Zahl),Tag(Schrift)} Formatiert
Select Case intColumnIndex
Case 1, 3: Call Layout.setLayout("Tag(Schrift)", objCurRange, "komplett")
Case 8, 9, 11:
Call Layout.setLayout("Tag(Summe)", objCurRange, "komplett")
objCurRange.NumberFormat = "0.00"
Case Else:
Call Layout.setLayout("Tag(Zahl)", objCurRange, "komplett")
If intRowIndex = 10 Then
objCurRange.NumberFormat = "0.00"
End If
End Select
'Die Hintergründe Werden angepasst
If boolWochenende Then
Call Layout.setLayout("Tag(Wochenende)", objCurRange, "interior")
Else
If boolFeiertag Then
Call Layout.setLayout("Tag(Feiertag)", objCurRange, "interior")
End If
End If
'Die Standart- bzw. Dfaultwerte werden gesetzt
Call setDefaultCellValues(boolWochenende, boolFeiertag, objCurRange, _
dateTmp, intRowIndex, intColumnIndex, objWorksheet)
Next intColumnIndex
dateTmp = DateAdd("y", CDbl(1), dateTmp)
Next intRowIndex
objWorksheet.Calculate
Set objCurRange = Nothing
End Sub
'----------------------------------------------------------------------------->
'
'
Private Function setDefaultCellValues(ByVal boolWochenende As Boolean, _
ByVal boolFeiertag As Boolean, _
objRange As Range, _
dateDay As Date, _
ByVal intRow As Integer, _
ByVal intColumn As Integer, _
objWorksheet As Worksheet)
Dim dateCopy As Date
'Ein Array welches die Spalte-Drei-Werte enthält:
'{A->Arbeitstag,W->Wochenende,F->Feiertag}
Dim strArrTagTyp(2) As String
strArrTagTyp(0) = "A" 'Arbeitstag
strArrTagTyp(1) = "W" 'Wochenende
strArrTagTyp(2) = "F" 'Feiertag
Dim strArrZeitTyp() As String
strArrZeitTyp() = OpenFormular.getAuswahlKriterien
' MsgBox dateDay
Select Case intColumn
Case 1:
objRange.Value = Kalendar.getWeekDay(dateDay)
Case 2:
objRange.NumberFormat = "dd/mm"
' MsgBox Format(dateDay, "dd/mm")
' MsgBox objRange.NumberFormat
objRange.Value = dateDay
' dateCopy = dateDay
' objRange.Value = dateCopy
Case 3:
If boolWochenende Then
objRange.Value = strArrTagTyp(1)
Else
If boolFeiertag Then
objRange.Value = strArrTagTyp(2)
Else
objRange.Value = strArrTagTyp(0)
End If
End If
Case 4, 5, 6, 7:
If boolWochenende Or boolFeiertag Then
'hier wird nicht gearbeitet
Else
objRange.NumberFormat = "hh:mm"
objRange.Value = Format(dateStandartwerte(intColumn - 4), "hh:mm")
End If
Case 8, 9, 10, 11:
'Kummuliereter Wert der Tatsächlichen Arbeitszeiten
If boolWochenende Or boolFeiertag Then
'es pasiiert nichts
Else
If intColumn = 9 Then
objRange.Value = objWorksheet.Cells(intRow, intColumn - 1).Value
Else
' Dim str As String
' str =
' Debug.Print str
objRange.FormulaLocal = FormelKonverter.getFormel(intRow, intColumn, "Tag")
End If
End If
' Case 9:
' 'Die Summe der hören Zeilen + Netto-Arbeitszeit
' Case 10:
' 'Die Differenz zwischen Ist und Soll
' Case 11:
' 'Die summierten Projektstunden
End Select
End Function
'----------------------------------------------------------------------------------------->
'
'
Private Sub createSummenRow(objWorksheet As Worksheet)
Dim intColumnStart, intColumnEnde, intColumnIndex, intRow As Integer
Dim objRange As Range
intColumnStart = 1
intColumnEnde = 12
'...SpecialCells(xlCellTypeLastCell) -> untere,rechte Ecke als Range Bsp.:(K33|K34)
intRow = objWorksheet.Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1
For intColumnIndex = intColumnStart To intColumnEnde
Select Case intColumnIndex
Case 1:
Set objRange = mergeCells(objWorksheet.Cells(intRow, intColumnIndex), 7, objWorksheet)
objRange.Value = "Summen"
Call Layout.setLayout("Summe(Schrift)", objRange, "komplett")
Case 2, 3, 4, 5, 6, 7:
Case 8, 9, 10, 11:
Set objRange = objWorksheet.Cells(intRow, intColumnIndex)
Call Layout.setLayout("Summe(Zahl)", objRange, "komplett")
objRange.FormulaLocal = FormelKonverter.getFormel(intRow, intColumnIndex, "Summe")
End Select
Next intColumnIndex
Set objRange = Nothing
End Sub
'---------------------------------------------------------------------------->
'Erzeugt den Code für die Monats-Tabellen-Blätter nachdem diese erzeugt wurden
'String strWorksheet:= Worksheet-Name um das CodeModul zu identifizieren
'Erklärung der eingefügten Funktion:
' - es wird das Worksheet_Change(...)-Ereigniss eingeführt
' - falls dieses auftritt wird dieses an das Modul 'EventCatcher' weitergereicht
' und dort weiterverarbeitet.
'
'
Private Sub createEventProcedure(objWorksheet As Worksheet)
Private Sub createEventProcedure()
Dim longStartLine As Long
Dim objVbComponent As VBComponent
' Application.ScreenUpdating = False
For Each VBComponent In ActiveWorkbook.VBProject.VBComponents
If VBComponent.Type = vbext_ct_Document And _
VBComponent.CodeModule.CountOfLines = 0 Then
Set objVbComponent = VBComponent
Exit For
End If
Next VBComponent
With objVbComponent.CodeModule
longStartLine = .CreateEventProc("Change", "Worksheet") + 1
.InsertLines longStartLine, " Call EventCatcher.Worksheet_ChangeEvent(target, ActiveSheet)"
End With
Application.VBE.MainWindow.Visible = False ' damit der Vis.Basic.Editor-Fenster wieder geschlossen wird
Set objVbComponent = Nothing
End Sub