VB Code help

[Anthony]

Hi all,

I have this code (mostly donated - thanks) that basicaly seaches column A in
"database" for todays date, if any rows found with todays date then certain
cells are copy/pasted elswhere.
when this copy is done , in another worksheet names "Adhoc" I have a simple
table to display these results.

Now if no data is found which contains todays date a simple msg box advises
so.
The proble is that my table in "adhoc" is still shown after the user
acknowledges the msg, but I dont want it to be shown at all - I just want the
msg box to be shown and the table to remain 'hidden'

Hope that makes sense, and here is the code I am working with

Sub View_todays_entries()

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
Application.ScreenUpdating = False
Columns("H:T").Select
Selection.EntireColumn.Hidden = False
Columns("F:I").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 6
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 14
Columns("O:S").Select
Selection.EntireColumn.Hidden = True
ActiveWindow.ScrollColumn = 13
ActiveWindow.ScrollColumn = 12
ActiveWindow.ScrollColumn = 11
ActiveWindow.ScrollColumn = 10
ActiveWindow.ScrollColumn = 5
ActiveWindow.ScrollColumn = 4
ActiveWindow.ScrollColumn = 3
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 1
Range("B25").Select

Sheets("database").Select
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)

Set rngFound = rngToSearch.Find _
(What:=Date, _
LookIn:=xlValues, _
LookAt:=xlWhole)
If rngFound Is Nothing Then
Sheets("Adhoc").Select
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
End Sub


many thanks

 

[Bob Phillips]

Untested.

Sub View_todays_entries()
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

Application.ScreenUpdating = False
Columns("H:T").EntireColumn.Hidden = False
Columns("F:I").EntireColumn.Hidden = True
Columns("O:S").EntireColumn.Hidden = True

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)

Set rngFound = rngToSearch.Find(What:=Date, _
LookIn:=xlValues, _
LookAt:=xlWhole)
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
End Sub