A
Adel Handal
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
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