Thema Datum  Von Nutzer Rating
Antwort
Rot Datum aus Zelle in Code verarbeiten
 03.10.2016 12:03:33 Justin
Solved
03.10.2016 12:10:55 Justin
NotSolved

Ansicht des Beitrags:
Von:
Justin		 Datum:
03.10.2016 12:03:33		 Views:
1245		 Rating:
     
Antwort:
 Nein
Thema:
Datum aus Zelle in Code verarbeiten

Hallo zusammen,

ich habe in einem Forum eine für mich passende automatische Kalendererstellung gefunden. Soweit habe ich schon einiges für mich angepasst.

Ich habe auf meiner Übersichtsseite einen Button erstellt. Dieser erstellt mir ein neues Tabellenblatt und führt den unten ausgeführten Code aus.

 

Da ich das Datum nicht immer im Code anpassen möchte, würde ich das Datum gerne auch auf der Übersichtsseite haben. 

In Zelle A9 und B9

In Zelle A10 und B10

Wenn das Datum drinne steht, soll dieses in den Code übernommen werden.

?
1
2
3
Public Sub Erstellen()
    Call Kalender_erstellen(ActiveSheet.Range("B1"), <strong>"01.01.16", "30.06.2016"</strong>, True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)
    Call Kalender_erstellen(ActiveSheet.Range("B16"), <strong>"01.07.16", "31.12.16"</strong>, True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)

 

Für eure Hilfe wäre ich sehr dankbar :-).

 

Liebe Grüße

 

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
Option Explicit
 
Public Sub Erstellen()
    Call Kalender_erstellen(ActiveSheet.Range("B1"), "01.01.16", "30.06.2016", True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)
    Call Kalender_erstellen(ActiveSheet.Range("B16"), "01.07.16", "31.12.16", True, True, True, 6, 6, 6, 4, 3, False, False, 1, 15)
End Sub
 
Public Sub Kalender_erstellen(Startposition As Range, A_datum As Date, E_datum As Date, Feiertage As Boolean _
                              , Sa As Boolean, So As Boolean, zeilen_nachunten As Integer, _
                              Farbe_sa As Integer, Farbe_so As Integer, Farbe_feiertag As Integer, _
                              Spaltenbreite As Integer, Tage_ein_zweistellig As Boolean, _
                              KW_ein_zweistellig As Boolean, Farbe_rahmenlinie As Integer _
                              , zeilenhöhe As Integer)
    Dim a As Date
    Dim spalte As Integer
    Dim zeile As Integer
    Dim Pos1_kw As Integer
    Dim Pos2_kw As Integer
    Dim Pos1_mon As Integer
    Dim Pos2_mon As Integer
    Dim b As Range
    spalte = Startposition.Column
    zeile = Startposition.Row
    Application.ScreenUpdating = False
    With ThisWorkbook.ActiveSheet
    ' Schauen ob in dem Bereich etwas steht
    For Each b In .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte + (E_datum - A_datum)))
    If b <> "" Then
    Application.ScreenUpdating = True
    .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte + (E_datum - A_datum))).Select
    MsgBox "Achtung in dem Bereich in dem der Kalender erstellt werden soll sind nicht alle zellen leer!", vbCritical, "Achtung"
    Exit Sub
    End If
    Next b
        ' Formatierungen
        .Range(Cells(zeile + 3, spalte), Cells(zeile + 3, spalte + (E_datum - A_datum))).ColumnWidth = Spaltenbreite
        With .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte + (E_datum - A_datum)))
                .Borders(xlEdgeLeft).LineStyle = xlContinuous
                .Borders(xlEdgeTop).LineStyle = xlContinuous
                .Borders(xlEdgeBottom).LineStyle = xlContinuous
                .Borders(xlEdgeRight).LineStyle = xlContinuous
                .Borders(xlInsideVertical).LineStyle = xlContinuous
                .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                .Borders.ColorIndex = Farbe_rahmenlinie
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .RowHeight = zeilenhöhe
                .Borders.LineStyle = xlContinuous
                .Borders.Weight = xlThin
        End With
        .Range(Cells(zeile + 1, spalte), Cells(zeile + 1, spalte + (E_datum - A_datum))).Borders(xlInsideVertical).LineStyle = xlNone
        ' Von A_datum bis E_datum
        For a = A_datum To E_datum
            ' Formatierung wenn Datum ist ein SA oder So oder Feiertag
            If Sa = True Then
            If Format(a, "ddd") = "Sa" Then _
                .Range(Cells(zeile + 1, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Interior.ColorIndex = Farbe_sa
            End If
            If So = True Then
            If Format(a, "ddd") = "So" Then _
                .Range(Cells(zeile + 1, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Interior.ColorIndex = Farbe_so
            End If
            If Feiertage = True Then
            If Ist_feiertag(a) <> "" Then
            .Range(Cells(zeile + 2, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Interior.ColorIndex = Farbe_feiertag
            ' Feiertags - kommentar einfügen
            Call Kommentar_formatieren(Cells(zeile + 3, spalte), Ist_feiertag(a))
            End If
            End If
            ' Kalenderwoche
            If Format(a, "ddd") = "Mo" Then Pos1_kw = Cells(zeile + 1, spalte).Column
            If Format(a, "ddd") = "Fr" Then Pos2_kw = Cells(zeile + 1, spalte).Column
            If Format(a, "ddd") = "Fr" And Pos1_kw <> 0 Then
            .Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)).Merge
            If KW_ein_zweistellig = True Then
            .Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)).NumberFormat = "@"
            .Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)) = Format(kalenderwoche_D(a), "##00")
            Else
            .Range(Cells(zeile + 1, Pos1_kw), Cells(zeile + 1, Pos2_kw)) = Format(kalenderwoche_D(a), "#0")
            End If
            Pos1_kw = 0
            End If
            ' Monat
            If Day(a) = 1 Then
            Pos1_mon = Cells(zeile, spalte).Column
            .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Borders(xlEdgeLeft).Weight = xlThick
            End If
            If Day(a) = Letzter_tag_im_monat(a) Then
            Pos2_mon = Cells(zeile, spalte).Column
            .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Borders(xlEdgeRight).LineStyle = xlContinuous
            .Range(Cells(zeile, spalte), Cells(zeile + zeilen_nachunten + 3, spalte)).Borders(xlEdgeRight).Weight = xlThick
            End If
            If Day(a) = Letzter_tag_im_monat(a) And Pos1_mon <> 0 Then
            .Range(Cells(zeile, Pos1_mon), Cells(zeile, Pos2_mon)).Merge
            .Range(Cells(zeile, Pos1_mon), Cells(zeile, Pos2_mon)) = Format(a, "mmmm")
            Pos1_mon = 0
            End If
            ' Tag zahl z.b. 6 oder 06
            If Tage_ein_zweistellig = True Then
            .Cells(zeile + 3, spalte).NumberFormat = "@"
            .Cells(zeile + 3, spalte) = Format(a, "dd")
            Else
            .Cells(zeile + 3, spalte) = Format(a, "d")
            End If
            ' Tag wochentag c.b. Mo
            .Cells(zeile + 2, spalte) = Format(a, "ddd")
            spalte = spalte + 1
        Next a
    End With
    Application.ScreenUpdating = True
    End Sub
 
Function Ostern(Yr As Integer) As Date
   Dim D As Integer
   D = (((255 - 11 * (Yr Mod 19)) - 21) Mod 30) + 21
   Ostern = DateSerial(Yr, 3, 1) + D + (D > 48) + 6 - _
    ((Yr + Yr \ 4 + D + (D > 48) + 1) Mod 7)
End Function
 
Public Function Ist_feiertag(Datum As Date) As String
    Ist_feiertag = ""
    ' Ostern
    If Datum = Ostern(Year(Datum)) Then Ist_feiertag = Ist_feiertag & "Ostern" & Chr(10)
    ' Neujahr
    If Datum = DateSerial(Year(Datum), 1, 1) Then Ist_feiertag = Ist_feiertag & "Neujahr" & Chr(10)
    ' Maifeiertag
    If Datum = DateSerial(Year(Datum), 5, 1) Then Ist_feiertag = Ist_feiertag & "Maifeiertag" & Chr(10)
    ' Karfreitag
    If Datum = Ostern(Year(Datum)) - 2 Then Ist_feiertag = Ist_feiertag & "Karfreitag" & Chr(10)
    ' Ostermontag
    If Datum = Ostern(Year(Datum)) + 1 Then Ist_feiertag = Ist_feiertag & "Ostermontag" & Chr(10)
    ' Christi Himmelfahrt
    If Datum = Ostern(Year(Datum)) + 39 Then Ist_feiertag = Ist_feiertag & "Christi Himmelfahrt" & Chr(10)
    ' Pfingstsonntag
    If Datum = Ostern(Year(Datum)) + 49 Then Ist_feiertag = Ist_feiertag & "Pfingstsonntag" & Chr(10)
    ' Pfingstmontag
    If Datum = Ostern(Year(Datum)) + 50 Then Ist_feiertag = Ist_feiertag & "Pfingstmontag" & Chr(10)
    ' Fronleichnam
    If Datum = Ostern(Year(Datum)) + 60 Then Ist_feiertag = Ist_feiertag & "Fronleichnam" & Chr(10)
    ' TagDeutscheEinheit
    If Datum = DateSerial(Year(Datum), 10, 3) Then Ist_feiertag = Ist_feiertag & "Tag der Deutschen Einheit" & Chr(10)
    ' Tag der Arbeit
    If Datum = DateSerial(Year(Datum), 5, 1) Then Ist_feiertag = Ist_feiertag & "Tag der Arbeit" & Chr(10)
    ' Reformationstag
    If Datum = DateSerial(Year(Datum), 10, 31) Then Ist_feiertag = Ist_feiertag & "Reformationstag" & Chr(10)
    ' Heiligabend
    'If Datum = DateSerial(Year(Datum), 12, 24) Then Ist_feiertag = Ist_feiertag & "Heiligabend" & Chr(10)
    ' 1. Weihnachtsfeiertag
    If Datum = DateSerial(Year(Datum), 12, 25) Then Ist_feiertag = Ist_feiertag & "1. Weihnachtsfeiertag" & Chr(10)
    ' 2. Weihnachtsfeiertag
    If Datum = DateSerial(Year(Datum), 12, 26) Then Ist_feiertag = Ist_feiertag & "2. Weihnachtsfeiertag" & Chr(10)
    ' Silvester
    'If Datum = DateSerial(Year(Datum), 12, 31) Then Ist_feiertag = Ist_feiertag & "Silvester" & Chr(10)
    ' Mariä Himmelfahrt
    'If Datum = DateSerial(Year(Datum), 8, 15) Then Ist_feiertag = Ist_feiertag & "Maria Himmelfahrt" & Chr(10)
    ' Buß- und Bettag
    'If Datum = CDate("25.12." & Year(Datum)) - Weekday("25.12." & Year(Datum), vbMonday) - 32 Then Ist_feiertag = Ist_feiertag & "Buß- und Bettag" & Chr(10)
    ' Weiberfastnacht
    'If Datum = Ostern(Year(Datum)) - 52 Then Ist_feiertag = Ist_feiertag & "Weiberfastnacht" & Chr(10)
    ' Rosenmontag
    'If Datum = Ostern(Year(Datum)) - 48 Then Ist_feiertag = Ist_feiertag & "Rosenmontag" & Chr(10)
     
    If Ist_feiertag <> "" Then Ist_feiertag = Left(Ist_feiertag, Len(Ist_feiertag) - 1)
End Function
 
Function kalenderwoche_D(Datum As Date) As Integer
    ''von Christoph Kremer, Aachen
    'Berechnt die KW nach DIN 1355
    Dim t As Date
    t = DateSerial(Year(Datum + (8 - Weekday(Datum)) Mod 7 - 3), 1, 1)
    kalenderwoche_D = (Datum - t - 3 + (Weekday(t) + 1) Mod 7) \ 7 + 1
End Function
 
Public Function Letzter_tag_im_monat(Datum As Date) As Integer
    Letzter_tag_im_monat = Day(DateSerial(Year(Datum), Month(Datum) + 1, "01") - 1)
End Function
 
Sub Kommentar_formatieren(Bereich As Range, Text As String)
    With Bereich
        .ClearComments
        .AddComment.Text Text:=Text
        .Comment.Visible = False
        .Comment.Shape.TextFrame.AutoSize = True
        .Comment.Shape.TextFrame.HorizontalAlignment = xlCenter
        .Comment.Shape.TextFrame.Characters.Font.Name = "Tahoma"
        .Comment.Shape.TextFrame.Characters.Font.Size = 9
    End With
End Sub

 

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Datum aus Zelle in Code verarbeiten
 03.10.2016 12:03:33 Justin
Solved
03.10.2016 12:10:55 Justin
NotSolved