View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
Anthony Anthony is offline
external usenet poster
 
Posts: 275
Default vb code help with date format

I cant get my macro to respond with any data.

Column A in €śdatabase€ť worksheet is formatted Date: Type: 14March2001 UK style

So why will this code, which is supposed to search that column for any data
with todays date and cop/paste it to other cells, return the MsgBox "No
entries made in the database for today " all the time.

It must be something to do with the date search and the incorrect format €“
but as Im a novice here I dont know where its going wrong.

Heres the code

Sub addhoc_call_log_View_todays_entries() ' First Box, 2nd macro
Sheets("Adhoc").Unprotect

Dim i As Integer
Dim rngToSearch As Range
Dim rngFound As Range
Dim rngFirst As Range
Dim rngDestination As Range
Dim rngAllRecords As Range
Dim wks1 As Worksheet, wks2 As Worksheet
Dim MyDate As Variant
Application.ScreenUpdating = False
Columns("H:T").EntireColumn.Hidden = False
Columns("F:I").EntireColumn.Hidden = True
Columns("O:AC").EntireColumn.Hidden = True
ActiveWindow.ScrollColumn = 2

Sheets("database").Range("G2:K100").ClearContents

Set wks1 = ThisWorkbook.Worksheets("database")
Set wks2 = ThisWorkbook.Worksheets("database")

On Error Resume Next
Set rngToSearch = wks1.Columns("A")
Set rngDestination = wks2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)

MyDate = Format(Date, "dd mmmm yyyy")
Set rngFound = rngToSearch.Find(What:=MyDate, _
LookIn:=xlValues, _
LookAt:=xlWhole)
Set rngFound = rngToSearch.Find(What:=Date, _
LookIn:=xlValues, _
LookAt:=xlWhole)
If rngFound Is Nothing Then


If rngFound Is Nothing Then
MsgBox "No entries made in the database for today "
Else
On Error GoTo err_handler
lngNextRow = 2
Set rngFirst = rngFound
Set rngAllRecords = rngFound
Do
Set rngAllRecords = Union(rngAllRecords, rngFound)
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
'rngAllRecords.EntireRow.Copy rngDestination.EntireRow
For Each c In rngAllRecords
wks1.Range(wks1.Cells(c.Row, "a"), wks1.Cells(c.Row, "g")).Copy
wks1.Range(wks1.Cells(lngNextRow, "g"), wks1.Cells(lngNextRow, "M"))
lngNextRow = lngNextRow + 1
Next
'wks3.PrintOut
Sheets("Adhoc").Select

End If
Exit Sub

err_handler:
MsgBox Error, , "Err " & Err.Number
Sheets("Adhoc").Protect
End If
End Sub

Thanks for helping