Der im Code hinterlegt Zeitraum ist 2010 bis 2050. Dieser kann aber leicht angepasst werden.
Im 2 Schritt öffnet sich ein Fenster mit der Bitte, die gewünschte Musterdatei auszuwählen. Diese wird dann durch den Code geöffnet. Deshalb muss sie vor Codeausführung auch geschlossen sein.
Die Mustertabelle wird geöffnet und es erfolgt noch eine Sicherheitsabfrage, ob auch die richtige Datei ausgewählt wurde.
Wird mit "Ja" bestätigt, wird die Datei 365 mal kopiert und in 12 Monatsordnern gespeichert.
Die Laufzeit beträgt ca 1 Minute. In der Statusleiste erscheint eine Anzeige, welche Datei gerade erstellt wird.
Nach Fertigstellung sehen wir 12 neue Ordner im Verzeichnis der Mustertabelle. Hier wurde jetzt das Jahr 2011 eingegeben.
Ein Blick in einen der Ordner, hier Januar
Der Code für ein allgemeines Modul
Public Sub Vorlage_kopieren()
'Code für ein allgemeines Modul
'*********************************
'Autor: Jürgen Hennekes
'*********************************
'Code dupliziert eine Mustertabelle 1x für jeden Tag eines Jahres
'Code erstellt 12 Monatsordner
On Error GoTo errExit
Dim WB As Workbook
Dim strInbox As String
Dim strPath As String
Dim strPfad As String
Dim intDay As Integer
Dim lngYear As Long
Dim Wahl As String
Dim strMonth(1 To 12) As String
Dim intMonth As Integer
Dim strYear As String
Dim intI As Integer
intI = 1
strInbox = InputBox("Für welches Jahr sollen die Dateien erstellt werden?", "Jahreseingabe")
Select Case strInbox
Case 2010 To 2050
Case Else
MsgBox "Ungültige Eingabe der Jahreszahl" & vbCr _
& "Erlaubt ist nur eine Zahl zwischen 2010 und 2050"
Exit Sub
End Select
strPath = Application.GetOpenFilename(filefilter:="Exceldateien (*.xls),*.xls", _
Title:="Bitte die Vorlage öffnen.")
Set WB = Application.Workbooks.Open(strPath)
Wahl = MsgBox("Ist das die richtige Vorlage: [" & WB.Name & " ]" & vbCr & _
"Sollen die Dateien erstellt werden?", vbYesNo, "Sicherheitsabfrage")
If Wahl = vbNo Then
Exit Sub
End If
Application.StatusBar = True
strMonth(1) = "Januar"
strMonth(2) = "Februar"
strMonth(3) = "März"
strMonth(4) = "April"
strMonth(5) = "Mai"
strMonth(6) = "Juni"
strMonth(7) = "Juli"
strMonth(8) = "August"
strMonth(9) = "September"
strMonth(10) = "Oktober"
strMonth(11) = "November"
strMonth(12) = "Dezember"
lngYear = CDbl(DateSerial(strInbox, 1, 1))
strPfad = WB.Path
With WB
For intMonth = 1 To 12
MkDir strMonth(intMonth) & "_" & strInbox
ChDir strPfad & "\" & strMonth(intMonth) & "_" & strInbox
For intDay = 1 To 31
Application.StatusBar = _
"Aktuell wird Datei [" & intI & "] für das Jahr " & strInbox & " erstellt."
.SaveAs Format(lngYear, "DD.MM.YYYY") & ".xls"
lngYear = lngYear + 1
intI = intI + 1
If Month(lngYear) > intMonth Then
Exit For
End If
Next intDay
ChDir ".."
Next intMonth
End With
WB.Close
Application.StatusBar = ""
MsgBox "Die Dateien für " & strInbox & " wurden erstellt.", 64
Exit Sub
errExit:
MsgBox "Es ist ein Fehler aufgetreten oder es wurde keine Datei ausgewählt.", 48
Application.StatusBar = ""
End Sub
|
||||||
