A
Anthony
I can’t 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 today’s 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 I’m a novice here I don’t know where it’s going wrong.
Here’s 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
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 today’s 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 I’m a novice here I don’t know where it’s going wrong.
Here’s 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