ExcelBanter - User defined date entry into message box?

Hi Nick,

It is most likely to be todays date needed but there may be occasions when a
different date is needed so I thought it best to include this input box from
the outset.

I'll post all my code so far - this pretty much works as it is but I want to
add this user defined date element if possible.

Sub FailedDeliveries()

'Macro recorded 01/09/2006 by tadhum

Dim nRows As Long
Dim i As Long
Dim Source As Range
Dim strCheckDate As String
Dim datCheck As Date
Dim datLatest As Date
Dim lngColumnDate As Long
Dim TodaysDate As Date

TodaysDate = Application.InputBox(prompt:="Please enter the relevant
date")

'First Spreadsheet (Red) copy latest date from Unentered POD (podnondel)
weekly report

ChDir "N:\2006 PRODUCTION STATS\LF Transport"
Workbooks.Open Filename:="N:\2006 PRODUCTION STATS\LF
Transport\Unentered POD Report.CSV"

lngColumnDate = 2
nRows = Cells.SpecialCells(xlCellTypeLastCell).Row

'Loop one time to find the latest date
For i = 2 To nRows
If (Len(Cells(i, lngColumnDate).Value) 0) Then

'Re-evaluate the cell contents
Cells(i, lngColumnDate).Activate
SendKeys "{F2}" 'go into edit mode
SendKeys "~" 'hit enter

datCheck = Format(Cells(i, lngColumnDate).Value, "m/d/yyyy")

If (datLatest < datCheck) Then datLatest = datCheck
End If
Next i

strCheckDate = Format(datLatest, "m/d/yyyy")

'Loop a second time to find all occurences of this date
For i = 2 To nRows
If (Len(Cells(i, lngColumnDate).Value) 0) Then
If (Format(Cells(i, lngColumnDate).Value, "m/d/yyyy") =
strCheckDate) Then
If (Source Is Nothing) Then
Set Source = Cells(i, lngColumnDate).EntireRow
Else
Set Source = Union(Source, Cells(i,
lngColumnDate).EntireRow)
End If
End If
End If
Next i

If (Source Is Nothing) Then
Call MsgBox("No dates found")
Exit Sub
End If

'Paste all latest dates into blank workbook
Source.Copy
Windows("Failed Deliveries.XLS").Activate
Sheets("Report").Select
Cells(Rows.Count, lngColumnDate).End(xlUp).Offset(1, -1).Select
ActiveSheet.Paste

'colour rows red
Selection.Font.ColorIndex = 3

'Delete columns A and B
Columns("A:B").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select

'Copy column headings from format sheet
Sheets("Format").Select
Rows("1:1").Select
Selection.Copy
Sheets("Report").Select
Rows("1:1").Select
ActiveSheet.Paste

'Close podnondel workbook
PathName = "N:\2006 PRODUCTION STATS\LF Transport\"
OutName1 = "Unentered POD Report " & Date & ".csv"
OutName1 = Replace(OutName1, "/", "_", 1, -1)
OutFile1 = PathName & OutName1

Windows("Unentered POD Report.csv").Activate
Workbooks("Unentered POD Report.csv").SaveAs Filename:=OutName1
ActiveWorkbook.Close

'Second Spreadsheet (Blue) copy latest date from weekly podreg report
'Not done yet!!

'Third spreadsheet (Black) 'Discrepancies Report' is daily so no need to
select latest date

ChDir "N:\2006 PRODUCTION STATS\LF Transport"
Workbooks.Open Filename:="N:\2006 PRODUCTION STATS\LF
Transport\Discrepancies Report.xls"

'Delete cell A16 to align first row
Range("A16").Select
Selection.Delete Shift:=xlToLeft
Rows("1:15").Select
Selection.Delete Shift:=xlUp

'Copy every 3rd cell in column C starting one row before the last row, and
paste into next blank row +1 in 'Failed Deliveries' worksheet col A
For i = 1 To Cells(Rows.Count, "c").End(xlUp).Row Step 3
With Workbooks("Failed Deliveries.xls").Sheets("Report")
Lr = .Cells(Rows.Count, "A").End(xlUp).Row + 1
Cells(i, "c").Copy .Cells(Lr, "A")
End With
Next i

'Copy every 3rd cell in column C starting at the last row, and paste into
next blank row +1 in 'Failed Deliveries' worksheet col H
Windows("Discrepancies Report.xls").Activate
For i = 1 To Cells(Rows.Count, "c").End(xlUp).Row Step 3
With Workbooks("Failed Deliveries.xls").Sheets("Report")
Lr = .Cells(Rows.Count, "H").End(xlUp).Row + 1
Cells(i + 1, "c").Copy .Cells(Lr, "H")
End With
Next i

'Close 'Discrepancies Report' workbook
PathName = "N:\2006 PRODUCTION STATS\LF Transport\"
OutName2 = "Discrepancies Report " & Date & ".xls"
OutName2 = Replace(OutName2, "/", "_", 1, -1)
OutFile2 = PathName & OutName2

Windows("Discrepancies Report.xls").Activate
Workbooks("Discrepancies Report.xls").SaveAs Filename:=OutFile2
ActiveWorkbook.Close

'Change number format and adjust column width
Range("A:A,D:D").Select
Range("D1").Activate
Selection.NumberFormat = "0"
Cells.Select
Cells.EntireColumn.AutoFit

End Sub

"NickHK" wrote:

One thing, because you expect a Date variable back, you do not use the "Set"
key owrd ; that is only for Object.
Dim TodaysDate as Date

Also, if you actually want today's date, you do not need to ask the user ;
you have "Date", which returns today's date.
As for the last, that depends what you want to do...

NickHK

"Meltad" ...
Thanks Nick,

I've put this at the start of my macro...
Set TodaysDate = Application.InputBox(prompt:="Please enter today's date",
Type:=1)
How do I ensure a date is accepted and recognised later in the code?
How can I now use 'TodaysDate' to copy relevant rows from my spreadsheets?

"NickHK" wrote:

Look at Application.InputBox in help

NickHK

"Meltad" ...

Hi all,

Can I start my macro with a message box/prompt for the user to enter
the
date and set this as 'todaysdate' (or something!) - I would then use
this
user defined date to go into 3 other workbooks, select all data for
that
date, copy the rows and paste into the original workbook.
Is this possible?!

Thank you!