PDA

View Full Version : View Calendar



justdriving
09-22-2011, 12:58 AM
Could someone help me to create this calendar in VBA?

justdriving
09-24-2011, 12:47 PM
Requesting your help,

justdriving
09-28-2011, 11:49 AM
Please suggest should I ask this help under paid help section. Or please suggest something.

justdriving
10-01-2011, 02:19 PM
...

Bob Phillips
10-02-2011, 02:31 AM
What needs to be done, it is already created.

online
10-04-2011, 03:48 AM
See the attachment... now

sorry not able to upload file

Bob Phillips
10-04-2011, 03:53 AM
See the attachment... now

What is your point?

shrivallabha
10-04-2011, 08:57 AM
VBA has built in Calendar Control. Also there's one in KBase I think. But it comes with a caution. Here's a thread which might be of help.
http://www.vbaexpress.com/forum/showthread.php?t=35548&highlight=design+time

justdriving
10-04-2011, 12:10 PM
I am still looking for VBA conversion of above attachment.

hardlife
10-04-2011, 03:03 PM
Option Explicit

Sub MakeCalendar_HELP_NEW()
'By John Walkenbach
'Distribute freely, but don't sell it
'http://j-walk.com/ss

Dim i As Integer

Dim YEAR_HELP As Integer
Dim MONTH_HELP As Integer
Dim x

YEAR_HELP = 2011
MONTH_HELP = 1

Range("a1").Activate

For i = 1 To 12

Select Case i
Case 1
ActiveCell.Offset(0, 0).Activate
Case 2
ActiveCell.Offset(0, 2).Activate
Case 3
ActiveCell.Offset(0, 2).Activate
Case 4
ActiveCell.Offset(10, -16).Activate
Case 5
ActiveCell.Offset(0, 2).Activate
Case 6
ActiveCell.Offset(0, 2).Activate
Case 7
ActiveCell.Offset(10, -16).Activate
Case 8
ActiveCell.Offset(0, 2).Activate
Case 9
ActiveCell.Offset(0, 2).Activate
Case 10
ActiveCell.Offset(10, -16).Activate
Case 11
ActiveCell.Offset(0, 2).Activate
Case 12
ActiveCell.Offset(0, 2).Activate
End Select



'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This procedure inserts a "live" calendar at the active
'cell. It uses eight rows and seven columns
'If it overwrites your data, tough. No undo.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Is the range empty?
'If Application.CountA(Range(ActiveCell, ActiveCell.Offset(7, 6))) <> 0 Then
' If MsgBox("OK to overwrite existing data?", vbYesNo, "Calendar Maker") <> vbYes Then Exit Sub
'End If

'Insert the month/year
'ActiveCell.Value = DateSerial(YEAR(Now), MONTH(Now), 1)
ActiveCell.Value = DateSerial(YEAR_HELP, MONTH_HELP, 1)
ActiveCell.NumberFormat = "mmmm, yyy"

'Insert day headings
With Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(1, 6))
.Formula = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 27
.Font.Bold = True
End With

'Insert an array formula
On Error GoTo NoCanDo
With Range(ActiveCell.Offset(2, 0), ActiveCell.Offset(7, 6))
'Formula would be too long, so insert shorter formula and replace characters.
.FormulaArray = "=IF(MONTH(DATE(y,m,1))<>MONTH(DATE(y,m,1)-(WEEKDAY(DATE(y,m,1))-1)+{0;1;2;3;4;5}*7+{1,2,3,4,5,6,7}-1),"""",DATE(y,m,1)-(WEEKDAY(DATE(y,m,1))-1)+{0;1;2;3;4;5}*7+{1,2,3,4,5,6,7}-1)"
.Replace What:=",m,", Replacement:=",MONTH(" & ActiveCell.Address(False, False) & "),"
.Replace What:="y,", Replacement:="YEAR(" & ActiveCell.Address(False, False) & "),"
.NumberFormat = "d"
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 36
End With

'Add some borders
With Range(ActiveCell, ActiveCell.Offset(7, 6))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With

' Merge and center month/year
Application.DisplayAlerts = False
With Range(ActiveCell, ActiveCell.Offset(0, 6))
.Merge
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 1
.Font.ColorIndex = 2
.Font.Bold = True
End With
Application.DisplayAlerts = True
'Exit Sub

MONTH_HELP = MONTH_HELP + 1

Next i

Cells.Select
Selection.ColumnWidth = 5.43

NoCanDo:
' MsgBox "There was a problem writing creating the calendar.", vbInformation
End Sub


happy and sunny day :hi:

justdriving
10-05-2011, 12:55 AM
Thanks, it was great help.

How can I modify above program that current month interior color to look different than remaining month.

I just wanted that formula don't appear in excel sheet. For this purpose, can I use: -

.cells.value = .cells.value

Bob Phillips
10-05-2011, 01:15 AM
If you don't have formulae, it won't be dynamic, that is it won't change if you scroll the year.

justdriving
10-05-2011, 01:53 AM
Hi Bob, above program was not dynamic.

Bob Phillips
10-05-2011, 02:18 AM
The original you showed was though, and you seemed to be suggesting that was what you aspired to. Anyway, if you are happy ...

justdriving
10-05-2011, 01:51 PM
Thanks, it was great help.

How can I modify above program that current month interior color to look different than remaining month.

I just wanted that formula don't appear in excel sheet. For this purpose, can I use: -

.cells.value = .cells.value

shrivallabha
10-05-2011, 09:29 PM
If your target is to hide formula then you can always use Protect Sheet method.

Select All Cells with formulas and then go to "Format cells" options. On the Protection Tab Check the option named "Hidden". Then protect the sheet. People using the sheet won't be able to see formulas!

GTO
10-05-2011, 09:57 PM
Thanks, it was great help.

How can I modify above program that current month interior color to look different than remaining month.

I just wanted that formula don't appear in excel sheet. For this purpose, can I use: -

.cells.value = .cells.value

What efforts have you made thus far?

JKwan
10-06-2011, 06:24 PM
here, try this

Option Explicit

Sub MakeCalendar_HELP_NEW()
'By John Walkenbach
'Distribute freely, but don't sell it
'http://j-walk.com/ss

Dim i As Integer

Dim YEAR_HELP As Integer
Dim MONTH_HELP As Integer
Dim x

YEAR_HELP = 2011
MONTH_HELP = 1

Range("a1").Activate

For i = 1 To 12

Select Case i
Case 1
ActiveCell.Offset(0, 0).Activate
Case 2
ActiveCell.Offset(0, 2).Activate
Case 3
ActiveCell.Offset(0, 2).Activate
Case 4
ActiveCell.Offset(10, -16).Activate
Case 5
ActiveCell.Offset(0, 2).Activate
Case 6
ActiveCell.Offset(0, 2).Activate
Case 7
ActiveCell.Offset(10, -16).Activate
Case 8
ActiveCell.Offset(0, 2).Activate
Case 9
ActiveCell.Offset(0, 2).Activate
Case 10
ActiveCell.Offset(10, -16).Activate
Case 11
ActiveCell.Offset(0, 2).Activate
Case 12
ActiveCell.Offset(0, 2).Activate
End Select



'''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This procedure inserts a "live" calendar at the active
'cell. It uses eight rows and seven columns
'If it overwrites your data, tough. No undo.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''

'Is the range empty?
'If Application.CountA(Range(ActiveCell, ActiveCell.Offset(7, 6))) <> 0 Then
' If MsgBox("OK to overwrite existing data?", vbYesNo, "Calendar Maker") <> vbYes Then Exit Sub
'End If

'Insert the month/year
'ActiveCell.Value = DateSerial(YEAR(Now), MONTH(Now), 1)
ActiveCell.Value = DateSerial(YEAR_HELP, MONTH_HELP, 1)
ActiveCell.NumberFormat = "mmmm, yyy"

'Insert day headings
With Range(ActiveCell.Offset(1, 0), ActiveCell.Offset(1, 6))
.Formula = Array("Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat")
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 27
.Font.Bold = True
End With

'Insert an array formula
On Error GoTo NoCanDo
With Range(ActiveCell.Offset(2, 0), ActiveCell.Offset(7, 6))
'Formula would be too long, so insert shorter formula and replace characters.
.FormulaArray = "=IF(MONTH(DATE(y,m,1))<>MONTH(DATE(y,m,1)-(WEEKDAY(DATE(y,m,1))-1)+{0;1;2;3;4;5}*7+{1,2,3,4,5,6,7}-1),"""",DATE(y,m,1)-(WEEKDAY(DATE(y,m,1))-1)+{0;1;2;3;4;5}*7+{1,2,3,4,5,6,7}-1)"
.Replace What:=",m,", Replacement:=",MONTH(" & ActiveCell.Address(False, False) & "),"
.Replace What:="y,", Replacement:="YEAR(" & ActiveCell.Address(False, False) & "),"
.NumberFormat = "d"
.HorizontalAlignment = xlCenter
If i = Month(Now) Then
.Interior.ColorIndex = 3
Else
.Interior.ColorIndex = 36
End If
End With

'Add some borders
With Range(ActiveCell, ActiveCell.Offset(7, 6))
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
End With

' Merge and center month/year
Application.DisplayAlerts = False
With Range(ActiveCell, ActiveCell.Offset(0, 6))
.Merge
.HorizontalAlignment = xlCenter
.Interior.ColorIndex = 1
.Font.ColorIndex = 2
.Font.Bold = True
End With
Application.DisplayAlerts = True
'Exit Sub

MONTH_HELP = MONTH_HELP + 1

Next i

Cells.Select
Selection.ColumnWidth = 5.43

NoCanDo:
' MsgBox "There was a problem writing creating the calendar.", vbInformation
End Sub