How about using autofilter to speed this up?
Sub DelRow_Criteria_Not_In_OandQ()
Selection.AutoFilter
Selection.AutoFilter Field:=15, Criteria1:="<* Return To Tsr *",
Operator:=xlAnd
Selection.AutoFilter Field:=17, Criteria1:="<* Sales *",
Operator:=xlAnd
Range("A2", Cells(Range("A2").End(xlDown).Row, _
Range("A2").End(xlToRight).Column)). _
SpecialCells(xlCellTypeVisible).EntireRow.Delete
Selection.AutoFilter
Application.ScreenUpdating = True
Application.Run ("QueryUpdate")
End Sub
This prevents you from evaluating potentially 1000s of line with
VB.
The AutoFilter code is much more efficient
HTH
Die_Another_Day
Kris wrote:
This is acting slow for me. I know it is alot of data to be processing
but if any one could help me streamline this it would be appreciated.
This is what I am using so far.
Sheets("Working").Select
Range("A2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.Run ("DelRow_Criteria_Not_In_OandQ")
End Sub
Sub DelRow_Criteria_Not_In_OandQ()
Dim rng As Integer
Dim i As Integer
rng = Selection.Rows.Count
ActiveCell.Offset(0, 0).Select
Application.ScreenUpdating = False
For i = 1 To rng
If Cells(ActiveCell.row, 15) = " Return To Tsr " Or _
Cells(ActiveCell.row, 17) = " Sales " Then
ActiveCell.Offset(1, 0).Select
Else
Selection.EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
Application.Run ("QueryUpdate")
End Sub
Kris wrote:
Yes I can incorporate this it basically gives me what I need. Thanks so
much for the help.
I might have some troubles changing every just right so that my pivot
tables will work correctly. If I do have more trouble I will be back.
Thank you again.
skatonni via OfficeKB.com wrote:
I could not get your code to work either. If you are not tied to your code
maybe you can incorporate this.
If not at least your question is at the top again.
First copy all the data to your "Working" sheet. Make a selection that spans
all the applicable rows.
Sub DelRow_Criteria_Not_In_OandQ()
Dim rng As Integer
Dim i As Integer
rng = Selection.Rows.Count
ActiveCell.Offset(0, 0).Select
Application.ScreenUpdating = False
For i = 1 To rng
If Cells(ActiveCell.row, 15) = " Return To Tsr " Or _
Cells(ActiveCell.row, 17) = " Sales " Then
ActiveCell.Offset(1, 0).Select
Else
Selection.EntireRow.Delete
End If
Next i
Application.ScreenUpdating = True
End Sub
Kris wrote:
I need to delete rows unless they have " Return To Tsr " (A space
before and after the phrase) in column O OR " Sales " (A space before
and after the word) in column Q.
I have had trouble getting this done right. What I am working with
currently is below.
I appreciate any help you can provide.
Thanks
Kris
Sub Day1TSR()
Dim row As Long
row = FindLastRow
Sheets("Day 1").Select
Selection.AutoFilter Field:=15, Criteria1:=" Return To Tsr "
ActiveWindow.ScrollColumn = 1
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Working").Select
Worksheets("Working").Cells(row, 1).Select
ActiveSheet.Paste
Sheets("Day 1").Select
Range("A1").Activate
Selection.AutoFilter
Application.Run ("QueryUpdate")
End Sub
Sub Day1Sales()
Dim row As Long
row = FindLastRow
Sheets("Day 1").Select
Selection.AutoFilter Field:=17, Criteria1:=" Sales "
ActiveWindow.ScrollColumn = 1
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Working").Select
Worksheets("Working").Cells(row, 1).Select
ActiveSheet.Paste
Sheets("Day 1").Select
Range("A1").Activate
Selection.AutoFilter
Application.Run ("Day1TSR")
End Sub
--
Message posted via OfficeKB.com
http://www.officekb.com/Uwe/Forums.a...mming/200607/1