Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Mart 2007 Perşembe

Prepare Calendar



'Module1

Option Explicit
Dim i As Single, ii As Single, No As Single
Dim Tarih As Date
Dim Hafta As Integer, Ay As Integer, Yıl As Integer, HaftaGün As Integer
Dim AyınSonuncuGünü As Double
Dim AyAlan(12) As Range
Dim Eleman As Worksheet, SayfaAdı As String, YeniSayfa As Worksheet

Sub TakvimHazırla() 'Prepare Calendar
On Error GoTo Hata
Yıl = InputBox("Lütfen takvimini hazırlamak istediğiniz yılın dört karekterlik sayısını giriniz" & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", "[PBİD®] Your Calender", VBA.Year(VBA.Now()))
Tarih = VBA.CDate(VBA.DateSerial(Yıl, 1, 1))
Call ÇizelgeHazırla(Yıl)
For i = 1 To 12
No = 1
Ay = i
AyınSonuncuGünü = IIf(Ay = 2, IIf((Yıl Mod 4) > 0, 28, 29), IIf(Ay = 4, 30, IIf(Ay = 6, 30, IIf(Ay = 9, 30, IIf(Ay = 11, 30, 31)))))
AyAlan(i).ClearContents
For ii = 1 To AyınSonuncuGünü
Tarih = VBA.DateSerial(Yıl, Ay, ii)
HaftaGün = VBA.DatePart("w", Tarih, vbMonday, vbFirstJan1)
Hafta = VBA.DatePart("ww", Tarih, vbMonday, vbFirstJan1)
If HaftaGün = 7 Then
AyAlan(i).Cells(No, HaftaGün + 1) = ii
AyAlan(i).Cells(No, 1) = Hafta
No = No + 1
Else
AyAlan(i).Cells(No, HaftaGün + 1) = ii
AyAlan(i).Cells(No, 1) = Hafta
End If
Next ii
Next i
Exit Sub
Hata:
MsgBox "Hatalı yıl girişi yapıldı..." & vbCrLf & vbCrLf & "Mustafa ULUSARAÇ 01ulusarac@superonline.com", vbExclamation, "[PBİD®] Prepare Calendar"
End Sub
Private Function ÇizelgeHazırla(Yıl) 'Prepare charts
On Error GoTo Hata
SayfaAdı = Yıl & "Takvimi"
For Each Eleman In ThisWorkbook.Worksheets
If Eleman.name = SayfaAdı Then GoTo SayfaBul
Next Eleman
Set YeniSayfa = ThisWorkbook.Worksheets.Add
YeniSayfa.name = SayfaAdı
GoTo SayfaDüzenle
SayfaBul:
Set YeniSayfa = Eleman
YeniSayfa.Select
SayfaDüzenle:
YeniSayfa.Cells.Delete Shift:=xlUp
YeniSayfa.Range("A:AH").ColumnWidth = 3
With YeniSayfa.Range("B2:AG2")
.Borders(xlEdgeLeft).LineStyle = xlContinuous: .Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).LineStyle = xlContinuous: .Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).LineStyle = xlContinuous: .Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).LineStyle = xlContinuous: .Borders(xlEdgeRight).Weight = xlMedium
.Font.Bold = True
.Merge
.Value = Yıl
.RowHeight = 24
.Font.Size = 24
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Interior.ColorIndex = 37
End With
For i = 1 To 3
For ii = 1 To 4
With YeniSayfa.Range(Cells((4 + (i - 1) * 8), (2 + (ii - 1) * 8)), Cells((11 + (i - 1) * 8), (9 + (ii - 1) * 8)))
.Font.Bold = True
.Borders(xlEdgeLeft).LineStyle = xlContinuous: .Borders(xlEdgeLeft).Weight = xlMedium
.Borders(xlEdgeTop).LineStyle = xlContinuous: .Borders(xlEdgeTop).Weight = xlMedium
.Borders(xlEdgeBottom).LineStyle = xlContinuous: .Borders(xlEdgeBottom).Weight = xlMedium
.Borders(xlEdgeRight).LineStyle = xlContinuous: .Borders(xlEdgeRight).Weight = xlMedium
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
With .Range(Cells(1, 1), Cells(1, 8))
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.ShrinkToFit = True
.Merge
.RowHeight = 20
.Font.Size = 18
.Cells(1, 1) = VBA.Format(VBA.DateSerial(VBA.Year(VBA.Date), (i - 1) * 4 + ii, 1), "mmmm")
.Interior.ColorIndex = 37
End With
With .Range(Cells(2, 1), Cells(2, 8))
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 90
.ShrinkToFit = True
.RowHeight = 62
.Font.Size = 10
.Cells(1, 1) = " Hafta/Week"
.Cells(1, 2) = " " & VBA.Format(vbMonday, "dddd")
.Cells(1, 3) = " " & VBA.Format(vbTuesday, "dddd")
.Cells(1, 4) = " " & VBA.Format(vbWednesday, "dddd")
.Cells(1, 5) = " " & VBA.Format(vbThursday, "dddd")
.Cells(1, 6) = " " & VBA.Format(vbFriday, "dddd")
.Cells(1, 7) = " " & VBA.Format(vbSaturday, "dddd")
.Cells(1, 8) = " " & VBA.Format(vbSunday, "dddd")
.Interior.ColorIndex = 34
End With
.Range(Cells(3, 1), Cells(8, 1)).Interior.ColorIndex = 34
With .Range(Cells(3, 1), Cells(8, 8))
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.ShrinkToFit = True
.Font.Size = 10
.Range(Cells(1, 2), Cells(6, 6)).Font.Color = vbBlue
.Range(Cells(1, 7), Cells(6, 8)).Font.Color = vbRed
Set AyAlan((i - 1) * 4 + ii) = .Range(Cells(1, 1), Cells(6, 8))
End With
End With
Next ii
Next i
Exit Function
Hata:
End Function

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul