excel - Calendar in VBA -
i'm creating vba application ask user start date , end date , output monthly calendar in excel sheets.
here, have code asks user month , year , outputs month in excel sheet
enter code here sub calendarmaker() activesheet.protect drawingobjects:=false, contents:=false, _ scenarios:=false application.screenupdating = false on error goto myerrortrap range("a1:g14").clear myinput = inputbox("type in month , year calendar ") if myinput = "" exit sub startday = datevalue(myinput) if day(startday) <> 1 startday = datevalue(month(startday) & "/1/" & _ year(startday)) end if range("a1").numberformat = "mmmm yyyy" range("a1:g1") .horizontalalignment = xlcenteracrossselection .verticalalignment = xlcenter .font.size = 18 .font.bold = true .rowheight = 35 end with range("a2:g2") .columnwidth = 11 .verticalalignment = xlcenter .horizontalalignment = xlcenter .verticalalignment = xlcenter .orientation = xlhorizontal .font.size = 12 .font.bold = true .rowheight = 20 end range("a2") = "sunday" range("b2") = "monday" range("c2") = "tuesday" range("d2") = "wednesday" range("e2") = "thursday" range("f2") = "friday" range("g2") = "saturday" range("a3:g8") .horizontalalignment = xlright .verticalalignment = xltop .font.size = 18 .font.bold = true .rowheight = 21 end range("a1").value = application.text(myinput, "mmmm yyyy") dayofweek = weekday(startday) curyear = year(startday) curmonth = month(startday) finalday = dateserial(curyear, curmonth + 1, 1) select case dayofweek case 1 range("a3").value = 1 case 2 range("b3").value = 1 case 3 range("c3").value = 1 case 4 range("d3").value = 1 case 5 range("e3").value = 1 case 6 range("f3").value = 1 case 7 range("g3").value = 1 end select each cell in range("a3:g8") rowcell = cell.row colcell = cell.column if cell.column = 1 , cell.row = 3 elseif cell.column <> 1 if cell.offset(0, -1).value >= 1 cell.value = cell.offset(0, -1).value + 1 if cell.value > (finalday - startday) cell.value = "" exit end if end if elseif cell.row > 3 , cell.column = 1 cell.value = cell.offset(-1, 6).value + 1 if cell.value > (finalday - startday) cell.value = "" exit end if end if next x = 0 5 range("a4").offset(x * 2, 0).entirerow.insert range("a4:g4").offset(x * 2, 0) .rowheight = 65 .horizontalalignment = xlcenter .verticalalignment = xltop .wraptext = true .font.size = 10 .font.bold = false .locked = false end with range("a3").offset(x * 2, 0).resize(2, _ 7).borders(xlleft) .weight = xlthick .colorindex = xlautomatic end with range("a3").offset(x * 2, 0).resize(2, _ 7).borders(xlright) .weight = xlthick .colorindex = xlautomatic end range("a3").offset(x * 2, 0).resize(2, 7).borderaround _ weight:=xlthick, colorindex:=xlautomatic next if range("a13").value = "" range("a13").offset(0, 0) _ .resize(2, 8).entirerow.delete activewindow.displaygridlines = false activesheet.protect drawingobjects:=true, contents:=true, _ scenarios:=true activewindow.windowstate = xlmaximized activewindow.scrollrow = 1 application.screenupdating = true exit sub myerrortrap: msgbox "you may not have entered month , year correctly." _ & chr(13) & "spell month correctly" _ & " (or use 3 letter abbreviation)" _ & chr(13) & "and 4 digits year" myinput = inputbox("type in month , year calendar") if myinput = "" exit sub resume end sub enter code here but code creates calendar 1 specified month in 1 excel sheet,
but want to input several months , vba should output several months in different excel sheets 1 month in each of them.
i tried creating while loop outputs whole code different excel sheets, did not work out.
here screenshot of excel
something can start with:
sub createcalendar(startdate integer, enddate integer) dim crow byte, ccol byte crow = day(startdate) ccol = 1 startdate = startdate enddate cells(crow, ccol).value = startdate 'change active cell "cells(crow, ccol)" format or whatever if month(startdate) = month(startdate + 1) crow = crow + 1 'same month next day -> next row - increase "+ 1" if ned more rows else 'new month crow = 1 'change first row ccol = ccol + 1 'next column - increase "+ 1" if ned more end if next end sub edit: based on edited question, try this:
sub setbord(brng range) 'saves space in createcalendar cus same pattern dim x byte x = 7 10 brng.borders(x).linestyle = 1 brng.borders(x).colorindex = 0 brng.borders(x).tintandshade = 0 brng.borders(x).weight = -4138 next end sub sub createcalendar(startdate long, optional enddate long) 'check input errors if startdate < 1 or enddate < 0 or startdate > 2958465 or enddate > 2958465 msgbox "dates out of range!" exit sub 'if startdate after enddate still @ least first month 'however, if want, can activate next 3 lines 'elseif enddate > 0 , enddate < startdate 'msgbox "if enddate set, needs after startdate" 'exit sub elseif (enddate - startdate) > 400 if msgbox("warning: creating calendar range of " & enddate - startdate & " days! sure?", 4) = 7 exit sub end if dim crow long, ccol byte, x byte 'set variables startdate = startdate - day(startdate) + 1 'always create full months crow = 1 range(cells(crow, 1), cells(crow, 7)) 'month header .horizontalalignment = -4108 .mergecells = true .numberformat = "@" .value = format(startdate, "mmmm yyyy") end setbord range(cells(crow, 1), cells(crow, 7)) crow = crow + 1 x = 1 7 'weekday header cells(crow, x) .horizontalalignment = -4108 .numberformat = "@" .value = format(x, "dddd") end next x = 1 7 step 2 'set borders setbord range(cells(crow, x), cells(crow + 24, x)) next setbord range(cells(crow, 1), cells(crow, 7)) crow = crow + 1 x = 4 20 step 4 setbord range(cells(crow + x, 1), cells(crow + x + 3, 7)) next ccol = (startdate - 1) mod 7 + 1 'set day numbers cells(crow, ccol).value = day(startdate) startdate = startdate + 1 if ccol = 7 ccol = 1 crow = crow + 4 else ccol = ccol + 1 end if loop while month(startdate) = month(startdate - 1) crow = crow - ((crow - 1) mod 27) + 27 loop while enddate > startdate end sub note: months have same height of 6 weeks @ least leave font :d
Comments
Post a Comment