Makro TakvimSenelik tek satirda

[Malatyali1]

Makro Takvim code var ama excel 2010 da olmuyor. Sizde nasil?

Option Explicit

Public Sub Erstellen()
Call Kalender_erstellen(ActiveSheet.Range("B5"), "01.01.09", "30.06.09", True, True, True, 5, 15, 45, 4, 3, False, False, 18, 15)
Call Kalender_erstellen(ActiveSheet.Range("B16"), "01.07.09", "31.12.09", True, True, True, 5, 15, 45, 4, 3, False, False, 18, 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 = xlDouble
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

 

[Necdet]

Merhaba,

2010 sürümde çalışıyor ama günleri yanlış yazıyor, Örneğin 3 aralığa Perşembe diyor.
Şöyle bir baktım almanca olmayınca olmuyor detaya da girmedim o kadar vaktim yok.

 

[Malatyali1]

bende niye olmuyor nerde yanlis yapiyorum. Copy Paste yapamayacak kadar gerizekali degilimdir saniyordum.

 

[Necdet]

Merhaba,

400 hatası aldığınızı söylüyorsunuz benim bu hata ile ilgili bir fikrim yok.

http://support.microsoft.com/kb/832136/tr

inceleyiniz.

 

[Malatyali1]

siz sadece copy paste mi yaptiniz da sizde oldu?

 

[Necdet]

siz sadece copy paste mi yaptiniz da sizde oldu?

Evet, sadece bir modüle kopyaladım ve oradan çalıştırdım.

 

[Malatyali1]

size bir excel dokumenti yollasam copy paste benim icin yapar misiniz?

 

[Malatyali1]

copy pastelik zamaniniz vardir herhalde?

 

[Malatyali1]

bende sizde 3. Araliginin neden Persembe olarak gösterdigini söylerim