Hi to all,

I have worksheet nammed HCP2006. colomn EK has numbers in some of it's
cells. The code below is to select only the rows that has numbers (not
blank) in colomn EK starting from row 6.

These filtered rows has to be copied to another worksheet in the same folder
that has the name WV_KP_06 which containes 12 sheets for 12 months and
according to the month (here it is June).

When cells in colomn EK is empty (all blank) an error occures the code does
not continue.

I want to add a Message box telling that there is nothing to be filtered and
to return every thing as it was before starting the code.

Note: this code is run when pressing a button on the HCP_2006 worksheet.

Thanks in advance,

Khalil Handal

Here is the code:

Sub KP6()

' Month of June06 KP

   Dim RngToFilter66 As Range

   Dim RngToCopy66 As Range

   Dim Destwks66 As Worksheet

   Dim DestCell66 As Range

   Dim LastRow66 As Long

   With ActiveSheet

       .Unprotect Password:="1230"

       'turn off any existing filter

       .AutoFilterMode = False

       Set RngToFilter66 = .Range("EK6", .Cells(.Rows.Count,
"EK").End(xlUp))

       RngToFilter66.AutoFilter Field:=1, Criteria1:="<>"

       If RngToFilter66.Cells.SpecialCells(xlCellTypeVisible).Count = 1
Then

           'no visible rows in filter.

           Set RngToCopy66 = Nothing

       Else

           With RngToFilter66

               Set RngToCopy66 = .Resize(.Rows.Count - 1, 1).Offset(1, 0) _

                   .Cells.SpecialCells(xlCellTypeVisible)

           End With

       End If

       .AutoFilterMode = False

       .Protect Password:="1230"

   End With

   Set Destwks66 = Nothing

   On Error Resume Next

   Set Destwks66 = Workbooks("wv_KP_06.xls").Worksheets("Jun")

   On Error GoTo 0

   If Destwks66 Is Nothing Then

       Set Destwks66 = Workbooks.Open(ThisWorkbook.Path &
"\WV_KP_06.xls").Worksheets("Jun")

       End If

   With Destwks66

       ' delete any previous lines after row 7

       Worksheets("Jun").Select

       Rows("7:50").Select

       Selection.ClearContents

       Range("A7").Select

       ' previous line added by me

       LastRow66 = .Cells(.Rows.Count, "B").End(xlUp).Row + 1

       Set DestCell66 = .Cells(LastRow66, "A")

   End With

   RngToCopy66.EntireRow.Copy _

       Destination:=DestCell66

   Application.CutCopyMode = False

End Sub