Auto populate dates

[waiter11]

Hi folks...
I need help from the expert out there.
I have an xls nutrition table that need to auto populate with dates
using a calendar instead of manually editing the date
See the macro code below
------------------------------------------
Sub Macro1()
'
' Macro1 Macro
' Macro recorded 11/15/2005 by waiter
'
' Keyboard Shortcut: Ctrl+Shift+P
'
Range("A1").Select
ActiveCell.FormulaR1C1 = " Sunday 10-22-06"
Range("A6").Select
ActiveCell.FormulaR1C1 = " Monday 10-23-06"
Range("A11").Select
ActiveCell.FormulaR1C1 = " Tuesday 10-24-06"
Range("A16").Select
ActiveCell.FormulaR1C1 = " Wednesday 10-25-06"
Range("A21").Select
ActiveCell.FormulaR1C1 = " Thursday 10-26-06"
Range("A26").Select
ActiveCell.FormulaR1C1 = " Friday 10-27-06"
Range("A31").Select
ActiveCell.FormulaR1C1 = " Saturday 10-28-06"
Range("G8").Select
With ActiveSheet.PageSetup
..PrintTitleRows = ""
..PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = ""
With ActiveSheet.PageSetup
..LeftHeader = ""
..CenterHeader = "&""Times New Roman,Bold""&14WEEK OF OCTOBER 22
2006"
..RightHeader = ""
..LeftFooter = ""
..CenterFooter = ""
..RightFooter = ""
..LeftMargin = Application.InchesToPoints(0.5)
..RightMargin = Application.InchesToPoints(0.5)
..TopMargin = Application.InchesToPoints(1)
..BottomMargin = Application.InchesToPoints(0.25)
..HeaderMargin = Application.InchesToPoints(0.5)
..FooterMargin = Application.InchesToPoints(0.25)
..PrintHeadings = False
..PrintGridlines = False
..PrintComments = xlPrintNoComments
..PrintQuality = 600
..CenterHorizontally = False
..CenterVertically = False
..Orientation = xlLandscape
..Draft = False
..PaperSize = xlPaperLegal
..FirstPageNumber = xlAutomatic
..Order = xlDownThenOver
..BlackAndWhite = False
..Zoom = 100
..PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
End Sub

Thanks.
Any help will be greatly appreciated

 

[Roger Govier]

Hi

Having set up all your formats, enter the formula
=$A$1+1 in cell A6
Make it +2 in A11, +3 in A16 etc.
Format the cells A1, A6, A11 etc. as Format>Cells>Number>Custom>dddd
mm-dd-yyyy

Then, just change the value in A1 each week to have the other cells
update automatically.

If you want it to automatically adjust to the Monday date of the current
week, then insert in cell A1
=TODAY()-WEEKDAY(TODAY(),3)

 

[Ardus Petus]

Here is your macro revisited:
It uses an UserForm named ufDateSelect which contains a Calendar control.
You validate a date by double-clicking it or clicking OK button
To cancel, press Escape or click Cancel button


See example: http://cjoint.com/?fCkUfR6FDO

HTH
--
AP

'----------------------------------------------------
Option Explicit
Sub Macro1()
'
' Macro1 Macro
' Macro recorded 11/15/2005 by waiter
'
' Keyboard Shortcut: Ctrl+Shift+P
'
Dim dStartDate As Date
Dim iDay As Integer

' Show dialog
ufDateSelect.Show

' If cancelled, exit sub
If ufDateSelect.bCancel Then Exit Sub

'Read selected date
dStartDate = ufDateSelect.ctlCalendar.Value

' Set and format the dates in sheet
For iDay = 0 To 6
With Cells(1 + iDay * 5, "A")
.Value = dStartDate + iDay
.NumberFormat = "dddd mm-dd-yy"
End With
Next iDay

With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
.PrintArea = ""
.LeftHeader = ""
.CenterHeader = "&""Times New Roman,Bold""&14WEEK OF " & _
UCase(Format(dStartDate, "mmmm d yyyy"))
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.5)
.RightMargin = Application.InchesToPoints(0.5)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.25)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperLegal
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveSheet.PrintOut Copies:=1, Collate:=True
End Sub
-----------------------------------------------------

Userform code:
'-------------------------------------------------------
Option Explicit

Public bCancel As Boolean

Private Sub cbCancel_Click()
bCancel = True
Me.Hide
End Sub

Private Sub cbOK_Click()
bCancel = False
Me.Hide
End Sub


Private Sub ctlCalendar_DblClick()
cbOK_Click
End Sub
'--------------------------------------------------------
"waiter11" <[email protected]> a écrit
dans le message de (e-mail address removed)...