Filtering

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

....

Set RngToFilter66 = .Range("EK6", .Cells(.Rows.Count,
"EK").End(xlUp))
On Error Resume Next
RngToFilter66.AutoFilter Field:=1, Criteria1:="<>"
On Error GoTo 0
If Err.Number <> 0 Then
MsgBox "Nothing filtered"
Exit Sub
End If
If RngToFilter66.Cells.SpecialCells(xlCellTypeVisible).Count = 1
Then

....

--
HTH

Bob Phillips

(replace somewhere in email address with gmail if mailing direct)

"Adel Handal" <adelbhandal@hotmail.com> wrote in message
news:enWX6P9AHHA.2328@TK2MSFTNGP02.phx.gbl...
> 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
>
>
>
>
>
>