VBA to insert date string

[BlueAngel]

Good Morning Excel Gurus,

I am using MS Excel 2003. I have a file that that contains 3 sheets. I am
going to be using this file as a standard template in my company. So that
when we receive new work, this file can be pulled up and used from the onset
providing a standard reporting vehicle.

I am not a programmer by any stretch of the imagination. I do have an
understanding that VBA can be used to automate Excel. My question is can
someone help me out with the following:

Once a person opens up the excel file:
1-The file is opened as read only. (This will prevent someone from
corrupting the file)
2-either a pop up box appears when the file is opened that asks "What date
range is your Delivery Schedule? Please enter Start Date" or a radio button
is on the tool bar "Delivery Schedule". When this is executed the user will
be prompted to enter a start date then an end date.
3-Once the dates have been specified VBA would automatically populate the
sheet Named "Delivery schedule" with the date range starting in cell C2.
Example if the user entered Start date of April 15,2010 and End Date of July
6, 2010, Column C2:F2 would Populate as follows:

April-10 May-10 Jun-10 Jul-10

4-I would also like to format the text orientation at 90 degrees.

5-I would then like the program to prompt the user to save the file.

Thank in advance for your help,

 

[Bob Phillips]

Private Sub Workbook_Open()
Dim StartDate As Date
Dim EndDate As Date
Dim Filename As String
Dim i As Long

On Error GoTo errorhandler
StartDate = InputBox("What date range is your Delivery Schedule? Please
enter Start Date")
If Not IsDate(StartDate) Then Err.Raise 99999
EndDate = InputBox("Supply end date")
If Not IsDate(EndDate) Then Err.Raise 99999
With Worksheets("Delivery Schedule")

Do

.Range("C2").Offset(0, i).Value = StartDate + i
.Range("C2").Offset(0, i).Orientation = 90
i = i + 1
Loop Until StartDate + i > EndDate
End With

Filename = Application.GetSaveAsFilename(, , , "Save File now")
If Filename = "False" Then Err.Raise 99999
ThisWorkbook.SaveAs Filename
Exit Sub

errorhandler:
MsgBox "Something went wrong"
Me.Close savechanges:=False
End Sub

'This is workbook event code.
'To input this code, right click on the Excel icon on the worksheet
'(or next to the File menu if you maximise your workbooks),
'select View Code from the menu, and paste the code

 

[Monarch]

For insertin macros...
open new workbook, Press ALT-F11
In new editor form left side doubleclick on ThisWorkbook
in right panel copy following code


Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As
Boolean)
OffToolbar
End Sub

Private Sub Workbook_Open()
OnToolbar
End Sub

Now , click on INSERT menu and choose MODULE
From left side double click on MODULES (if tree is not open) and then
double click on MODULE1
insert following code

Sub OnToolbar()
Application.CommandBars.Add(Name:="BlueAngel Macros",
Temporary:=True).Visible = True
Application.CommandBars("BlueAngel Macros").Position = msoBarBottom
Set MyC = Application.CommandBars("BlueAngel
Macros").Controls.Add(Type:=msoControlButton, Temporary:=True, Before:=1)
With MyC
.BeginGroup = True
.Style = msoButtonCaption
.Caption = "Create and Save New Workbook"
.OnAction = "CreateWB"
End With
End Sub
Sub OffToolbar()
On Error Resume Next
Application.CommandBars("ASUS NB_Invent Report").Delete
End Sub

Public Sub CreateWB()
Dim StartDate As Date
Dim EndDate As Date
Dim MonthDiff As Integer

StartDate = InputBox("Please enter Start Date:", , Now())
EndDate = InputBox("Please enter End Date:", , Now())
MonthDiff = DateDiff("m", StartDate, EndDate)

For i = 1 To MonthDiff
Cells(1, i) = Format(DateAdd("m", i, StartDate), "mmm-yy")
Cells(1, i).Orientation = 90
Next

Sheets(ActiveSheet.Name).Copy
Newname = Application.GetSaveAsFilename("NewWB", "Excel WorkBook
(*.xls), *.xls", , "Save File now")
ActiveWorkbook.SaveAs Filename:=Newname, FileFormat:=xlNormal
ActiveWorkbook.Close
ThisWorkbook.Saved = True

End Sub


Now, close editor and save&close workbook
When you open it in the bottom you will find new toolbar with button
"Create and save New workbook". This text is changeable in above code.