Could someone help me to create this calendar in VBA?
Could someone help me to create this calendar in VBA?
Requesting your help,
Please suggest should I ask this help under paid help section. Or please suggest something.
...
What needs to be done, it is already created.
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
See the attachment... now
sorry not able to upload file
Last edited by online; 10-04-2011 at 03:59 AM. Reason: attachment was missing
What is your point?Originally Posted by online
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
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/show...ht=design+time
Regards,
--------------------------------------------------------------------------------------------------------
Shrivallabha
--------------------------------------------------------------------------------------------------------
Using Excel 2016 in Home / 2010 in Office
--------------------------------------------------------------------------------------------------------
I am still looking for VBA conversion of above attachment.
You can try this
[VBA]
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
[/VBA]
happy and sunny day
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
If you don't have formulae, it won't be dynamic, that is it won't change if you scroll the year.
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
Hi Bob, above program was not dynamic.
The original you showed was though, and you seemed to be suggesting that was what you aspired to. Anyway, if you are happy ...
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
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!
Regards,
--------------------------------------------------------------------------------------------------------
Shrivallabha
--------------------------------------------------------------------------------------------------------
Using Excel 2016 in Home / 2010 in Office
--------------------------------------------------------------------------------------------------------
What efforts have you made thus far?
here, try this
[VBA]
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
[/VBA]
Posting Permissions
Reply With Quote
