Tabellenblätter erstellen

Hallo liebes Forum,
Ich habe eine Frage bezüglich einer Excel-Aufgabe, wo ich nicht weiterkomme.
Und zwar soll ich eine Tabelle für jeden Monat eines Jahres erzeugen, welche in das entsprechende Tabellenblatt eingetragen wird. Ich habe das für die ersten beiden Monate mal mit einer Aufzeichnung als Makro gemacht und hier ist die Datei zu finden:
https://drive.google.com/open?id=0Bywnp5Bpgp_gZ1FjWUVxYnBJeVk
Meine Frage nun: Wie kann ich das eleganter mit VBA lösen? Also die KW-Wochen sollten für jeden Monat fortlaufend gezählt werden. Und wenn man auf den Button klickt, sollte ein Fenster erscheinen, wo man auch das Jahr auswählen kann. Drei Jahre sollten es mindestens sein.
Kann mir jemand helfen?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
kannst mal diesen Code testen!
Modul Modul1

Option Explicit 
 
Sub Maschinenbenutzung() 
Dim varJahr 
Dim n&, i&, ii&, nKW& 
Dim strTabName$ 
Dim Datum As Date 
Dim oWS As Worksheet, oRefTabelle As Worksheet 
 
Const AnzahlJahr& = 3 'Anzahl Jahre 
Set oRefTabelle = Tabelle1 'Referenztabelle 
 
 
varJahr = Application.InputBox("Geben sie das Jahr ein", "Jahr", Year(Date), Type:=1) 
If VarType(varJahr) = vbBoolean Then Exit Sub 
 
On Error GoTo ErrorHandler: 
Call Events(False) 
 
For n = 1 To 12 * AnzahlJahr 
    Datum = DateSerial(varJahr, n, 1) 
    strTabName = Format(DateSerial(varJahr, n, 1), "mmmm yyyy") 
     
    If Not CheckTabelle(strTabName) Then 
        oRefTabelle.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 
        Set oWS = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 
        oWS.Name = strTabName 
        ii = 9 
 
        Do While Month(Datum) = Month(DateSerial(varJahr, n, 1)) 
            oWS.Cells(2, ii).Value = "KW" & KW(Datum) 
            Datum = Datum + 7 
            ii = ii + 1 
        Loop 
         
        For ii = ii To 13 
            oWS.Cells(2, ii).Value = "" 
        Next ii 
        Call LoescheButton(oWS) 
    End If 
Next n 
 
ErrorHandler: 
Application.Goto oRefTabelle.Cells(1, 1) 
Call Events(True) 
 
If Err.Number <> 0 Then 
    MsgBox Err.Description, vbCritical, "Fehler: " & Err.Number 
End If 
End Sub 
 
Function CheckTabelle(strTabName$) As Boolean 
On Error Resume Next 
CheckTabelle = ThisWorkbook.Sheets(strTabName).Index <> 0 
Err.Clear 
Err.Number = 0 
On Error GoTo 0 
End Function 
 
Private Function KW(d As Date) As Integer 
Dim t As Variant 
    t = DateSerial(Year(d + (8 - Weekday(d)) Mod 7 - 3), 1, 1) 
    KW = (d - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1 
End Function 
 
Private Sub LoescheButton(oWS As Worksheet) 
On Error Resume Next 
oWS.DrawingObjects.Delete 
Err.Clear 
Err.Number = 0 
On Error GoTo 0 
End Sub 
 
Private Sub Events(booSchalter As Boolean) 
With Application 
    .ScreenUpdating = booSchalter 
    .DisplayAlerts = booSchalter 
    .EnableEvents = booSchalter 
    .Calculation = IIf(booSchalter, xlCalculationAutomatic, xlCalculationManual) 
End With 
End Sub

Gruß Tino

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabellenblätter erstellen

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread