....
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" <(E-Mail Removed)> wrote in message
news:(E-Mail Removed)...
> 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
>
>
>
>
>
>
|
Similar Threads
