Solved

Deleting a bunch of rows.  Autofilter

Posted on 2013-12-26
37
210 Views
Last Modified: 2014-01-10
I have another delete rows request... prefer with autofilter, (it is a bigger file and will delete around 25,000 rows)
On column AG or ActiveSheet.UsedRange.AutoFilter Field:=33,

How would I modify the code below to delete rows based on the following:

I want to delete everything, except the blanks, and dates = today, and yesterday.


Ending with the filter on only today and yesterdays records.  (no blanks)  -R-




Sub Macro()
    Rows("1:1").AutoFilter
    ActiveSheet.UsedRange.AutoFilter Field:=1, Criteria1:="=-", _
        Operator:=xlOr, Criteria2:= _
        "=-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------"
    LastRow = Cells(Cells.Rows.Count, 1).End(xlUp).Row
    LastColumn = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
    Range(Range("A2"), Cells(LastRow, LastColumn)).SpecialCells(xlCellTypeVisible).Delete Shift:=xlUp
End Sub 

Open in new window

ZGSRF029.xlsx
0
Comment
Question by:RWayneH
  • 19
  • 14
  • 3
37 Comments
 
LVL 45

Expert Comment

by:aikimark
ID: 39742000
Did your posted workbook include the rows you want to delete?  This data looks like it might have already been cleaned.
0
 

Author Comment

by:RWayneH
ID: 39742091
Sorry it proably did.  Here is another sample to work from. -R-
ZGSRF029v2.xlsx
0
 

Author Comment

by:RWayneH
ID: 39742093
Not sure if this is an issue, but I did not recall if the autofilter was on or off when this needs to run.  If it matters I can look that up. -R-
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39743063
which of the several date columns need to be checked?  

Note: AG is not a date column.
0
 

Author Comment

by:RWayneH
ID: 39743349
I am so sorry, I had to run some code to format the file...  this new sample file is the one.  AG is a date in this one.  I appreciate you hangin with me on this one.  Thanks. -R-
ZGSRF029v3.xlsx
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39743655
You will need to run this from an .xlsm or .xls workbook, since .xlsx workbooks do not allow macro execution.
Option Explicit

Public Sub Q_28325796()
    Dim dtToday As Date
    Dim wks As Worksheet
    Dim rng As Range
    Dim lngLoop As Long
    Dim lngEndRow As Long
    Dim lngStartRow As Long
    
    Set wks = ActiveSheet
    dtToday = Date
    
    'delete the hyphen row
    Set rng = wks.Range("A1").End(xlDown)
    If rng.Text Like "-*" Then
        rng.EntireRow.Delete
        Set rng = wks.UsedRange
    End If
    'iterate the AG cells from bottom to top, deleting the rows
    'with dates <> yesterday or today
    Application.ScreenUpdating = False
    lngEndRow = -1
    lngStartRow = lngEndRow + 1
    lngLoop = wks.Range("AG2").End(xlDown).Row
    For lngLoop = lngLoop To 2 Step -1
        If IsDate(wks.Cells(lngLoop, 33).Text) Then
            Select Case wks.Cells(lngLoop, 33).Text
                Case dtToday - 1 To dtToday
                    lngStartRow = lngLoop + 1
                    If lngStartRow <= lngEndRow Then
                        wks.Range(wks.Rows(lngStartRow), wks.Rows(lngEndRow)).Delete
                        Application.StatusBar = "Deleted rows: " & lngStartRow & " to " & lngEndRow
                    End If
                    lngEndRow = -1
                Case Else
                    If lngEndRow = -1 Then
                        lngEndRow = lngLoop
                    End If
            End Select
        Else
            lngStartRow = lngLoop + 1
            If lngStartRow <= lngEndRow Then
                wks.Range(wks.Rows(lngStartRow), wks.Rows(lngEndRow)).Delete
                Application.StatusBar = "Deleted rows: " & lngStartRow & " to " & lngEndRow
            End If
            lngEndRow = -1
        End If
    Next
    Application.ScreenUpdating = True
    ActiveSheet.UsedRange.AutoFilter Field:=33, Criteria1:=">=" & dtToday - 1, Operator:=xlAnd, Criteria2:="<=" & dtToday
    Application.StatusBar = vbNullString
End Sub

Open in new window

0
 

Author Comment

by:RWayneH
ID: 39744594
This macro did work?  Perphaps because today is a Sunday and there was no data = today, however there was some yesterday data,  just like tomorrow there will only be today data and not any yesterday data.

File v4 is after your macro run
File v5 was before your macro run
File v6 is what it is supposed to look like after todays running.

Any idea what went wrong? -R-
ZGSRF029v4.xlsx
0
 

Author Comment

by:RWayneH
ID: 39744600
Samplev5
ZGSRF029v5.xlsx
0
 

Author Comment

by:RWayneH
ID: 39744607
What the final solution should produce V6, even though there is only yesterdat data 12-28, no data for today 12-29 a Sunday.  When run tomorrow 12-30, there will only be today data, and no yesterday, because the only data previously was a yesterday, leaving the 12-30 running data as just that day.
ZGSRF029v6.xlsx
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39744608
The dates are being compared as text values.

Change line 51 to
    ActiveSheet.UsedRange.AutoFilter Field:=33, Criteria1:="=" & dtToday - 1, Operator:=xlOr, Criteria2:="=" & dtToday

Open in new window

0
 
LVL 45

Expert Comment

by:aikimark
ID: 39744612
Just to be on the safe side, change line 28 to
            Select Case CDate(wks.Cells(lngLoop, 33).Value)

Open in new window

0
 

Author Comment

by:RWayneH
ID: 39744622
Ok, I made edits and the final output is still not being completed.. (see what is left in the filter of column AG of the SampleV6 file.  Something is still not right..  We are deleting everything except the today, yesterday and blanks.  Leaving the filter on yesterday and today (no blanks)

there are still plenty of records left even after your edits..  ?    -R-
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39744749
Good catch.  I've simplified the algorithm and it is much faster than any prior version.  To facilitate testing, I added an optional parameter that allows you/me to supply a date, rather than using the system date on the PC.  The results seem to be what you want.
Option Explicit

Public Sub Q_28325796(Optional parmDate)
    Dim dtToday As Date
    Dim wks As Worksheet
    Dim rng As Range
    Dim lngLoop As Long
    Dim lngEndRow As Long
    Dim lngStartRow As Long
    
    Set wks = ActiveSheet
    If IsMissing(parmDate) Then
        dtToday = Date
    Else
        dtToday = parmDate
    End If
    'delete the hyphen row
    Set rng = wks.Range("A1").End(xlDown)
    If rng.Text Like "-*" Then
        rng.EntireRow.Delete
        Set rng = wks.UsedRange
    End If
    Application.ScreenUpdating = False
    
    'Insert a new column beside AG and create a header
    wks.Columns(34).Insert
    wks.Cells(1, 34).Value = "DateValue"
    'populate the new column with date values from column AG
    wks.Range(wks.Cells(2, 34), wks.Cells(wks.Cells.SpecialCells(xlCellTypeLastCell).Row, 34)).FormulaR1C1 = "=N(rc[-1])"
    'sort by the new date value column
    wks.Range("A1").CurrentRegion.Sort key1:=wks.Cells(1, 34), header:=xlYes
    
    'iterate the AH cells from bottom to top, deleting the rows
    'with dates <> yesterday or today
    lngEndRow = -1
    lngStartRow = lngEndRow + 1
    lngLoop = wks.Range("AH2").End(xlDown).Row
    For lngLoop = lngLoop To 2 Step -1
        Select Case wks.Cells(lngLoop, 34).Value
            Case dtToday - 1 To dtToday, 0
                lngStartRow = lngLoop + 1
                If lngStartRow <= lngEndRow Then
                    wks.Range(wks.Rows(lngStartRow), wks.Rows(lngEndRow)).Delete
                    Application.StatusBar = "Deleted rows: " & lngStartRow & " to " & lngEndRow
                End If
                lngEndRow = -1
            Case Else
                If lngEndRow = -1 Then
                    lngEndRow = lngLoop
                End If
        End Select
    Next
    'delete the datevalue column
    wks.Columns(34).Delete
    'sort by column 1
    wks.Range("A1").CurrentRegion.Sort key1:=wks.Cells(1, 1), header:=xlYes
    
    Application.ScreenUpdating = True
    ActiveSheet.UsedRange.AutoFilter Field:=33, Criteria1:="=" & dtToday - 1, Operator:=xlOr, Criteria2:="=" & dtToday
    Application.StatusBar = vbNullString
End Sub

Open in new window

0
 
LVL 10

Accepted Solution

by:
broro183 earned 500 total points
ID: 39744930
hi RWayneH,


Your example file looks like an extract from SAP (based on the nature of the Sales Order/Shipment/Delivery number series). If it is a SAP extract (or even an extract from another system), can you set up a variant or enter the date parameters in the initial screen?
This approach would remove the need for modifying the data set to such a great extent after it has been extracted to Excel.

When I made the following macro the last post to the thread had been Aikimark adding the excel zone which is what made me notice this thread. Lots of new posts have been made since yesterday.
The below code doesn`t work yet because of the date conversion (see line between the asterisks), but it provides an alternative structure to Aikimark`s, which may be able to be modified. Only use this on a copy of your file!
I will try and figure out the correct syntax for the date filtering over the next few days...

Aikimark, for pure speed your code would probably be faster if it identified the range to delete) perhaps using a variant array (in memory) and then performed a single delete command on the range which should be contiguous (since you have sorted the data).

Option Explicit

Sub FilterColAGAndDeleteRows()
Dim ws As Worksheet
Dim AfRng As Range
Dim AfDataOnlyRng As Range
Dim VisClls As Range
Dim ColToFilter As Long

    Set ws = ActiveSheet
    ColToFilter = 33    'column AG

    With ws
        'test if autofilters exist & if so, remove them.
        If .AutoFilterMode Then
            .AutoFilterMode = False
        End If
        ''to include populated rows on the sheet (down to the first blank row within the data) in the autofilter range
        '    Set AfRng = .Rows("1:1")
        'to include all populated rows on the sheet in the autofilter range (the "offset(0,1)" is to include an extra column)
        Set AfRng = .Range(.Cells(1, 1), LastCell(ws).Offset(0, 1))
    End With

    With AfRng
        'add the row numbers into the first blank column. The row number is to identify the original order before sorting column AG.
        'After the deletions are done the sheet is resorted to the "original order".
        With .Offset(0, .Columns.Count - 1).Resize(.Rows.Count, 1)
            .FormulaR1C1 = "=ROW(RC)"
            .Value2 = .Value2
        End With
        Set AfDataOnlyRng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count)
        .AutoFilter

        'sort by column AG to ensure that there is only one contiguous area to delete when the filtering is applied.
        'This may make the deletions faster.
        With ws.AutoFilter.Sort
            With .SortFields
                .Clear
                .Add Key:=AfRng.Columns(ColToFilter), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
            End With
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

'***********************************************************************
        'apply the filter. NB: this approach assumes that there are no future dated deliveries.
        .AutoFilter Field:=ColToFilter, Criteria1:="<" & CLng(DateSerial(Year(Date - 2), Month(Date - 2), Day(Date - 2))), Operator:=xlOr, Criteria2:="<>          "
'***********************************************************************

        'Check for visible cells & if so, delete them.
        On Error Resume Next
        Set VisClls = AfDataOnlyRng.SpecialCells(xlCellTypeVisible)
        On Error GoTo 0
        If Not VisClls Is Nothing Then
'NOTE, currently the wrong cells are deleted due to the incorrect date filtering

            VisClls.EntireRow.Delete Shift:=xlUp
        End If
        'Change the filter so it that blanks aren't shown.
        .AutoFilter Field:=ColToFilter, Criteria1:="<>          "
    End With

    'sort by the added column to return the sheet to the original row order.
    With ws.AutoFilter.Sort
        With .SortFields
            .Clear
            .Add Key:=AfRng.Columns(AfRng.Columns.Count), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
        End With
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


    MsgBox "Done"
    Set VisClls = Nothing
    Set AfDataOnlyRng = Nothing
    Set AfRng = Nothing
    Set ws = Nothing

End Sub
Function LastCell(ws As Excel.Worksheet) As Excel.Range
'22/09/2013, RB: written as "Function AttemptAtARobustLastCellFinder_v4(ws As Worksheet) As Range" for:
'http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39474286
'inspired by FP's comments about a "binary chop" approach http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39380467
'still subject to the limitations of CountA which Qlemo mentioned: http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39380520

Dim PercentArr As Variant    'this can probably be written better
Dim PercentageMultiplier As Double
Dim PercentInd As Long    'percent loop index
Dim LastRow As Long
Dim LastCol As Long
Dim RowsInWs As Long
Dim ColsInWs As Long
Dim LoopInd As Long
Dim UpperLim As Long
Dim BlockSizer As Long
Dim FirstRowOfUsedRng As Long

    With ws
        RowsInWs = .Rows.Count
        ColsInWs = .Columns.Count
    End With
    PercentArr = Array(0.5, 0.3, 0.1, 0.05, 0.03, 0.01, 0.005, 0.003, 0.001, 1)

    'run a loop to find the last row
    'v4, amended in case the first row of the used range is not Row 1.
    With ws.UsedRange
        UpperLim = Application.WorksheetFunction.Min(RowsInWs, .Cells(1, 1).Row - 1 + .Rows.Count)
    End With

    For PercentInd = LBound(PercentArr) To UBound(PercentArr)

        PercentageMultiplier = PercentArr(PercentInd)
        If PercentageMultiplier <> 1 Then
            BlockSizer = PercentageMultiplier * RowsInWs
        Else
            BlockSizer = 1
        End If

        For LoopInd = UpperLim To 1 Step -BlockSizer
            If (LoopInd - BlockSizer + 1) > 0 Then
                If Application.CountA(ws.Range(LoopInd - BlockSizer + 1 & ":" & LoopInd)) Then
                    Exit For
                End If
            Else
                Exit For
            End If
        Next LoopInd

        UpperLim = LoopInd
    Next PercentInd

    'v4: .max is used to allow for empty sheets
    LastRow = Application.WorksheetFunction.Max(1, UpperLim)

    'run a loop to find the last column
    'v4, amended in case the first column of the used range is not column 1.
    With ws.UsedRange
        UpperLim = Application.WorksheetFunction.Min(ColsInWs, .Cells(1, 1).Column - 1 + .Columns.Count)
    End With
    For PercentInd = LBound(PercentArr) To UBound(PercentArr)

        PercentageMultiplier = PercentArr(PercentInd)
        If PercentageMultiplier <> 1 Then
            BlockSizer = PercentageMultiplier * ColsInWs
        Else
            BlockSizer = 1
        End If

        For LoopInd = UpperLim To 1 Step -BlockSizer
            If (LoopInd - BlockSizer + 1) > 0 Then
                With ws
                    'Searches entire columns
                    'v4 corrected as per http://www.experts-exchange.com/Programming/Languages/Visual_Basic/VB_Script/Q_28203209.html#a39392583
                    If Application.CountA(.Range(.Cells(1, LoopInd - BlockSizer + 1), .Cells(RowsInWs, LoopInd))) Then
                        Exit For
                    End If
                End With
            Else
                Exit For
            End If
        Next LoopInd

        UpperLim = LoopInd
    Next PercentInd

    'v4: .max is used to allow for empty sheets
    LastCol = Application.WorksheetFunction.Max(1, UpperLim)

    '    'User feedback for testing
    Debug.Print "Last row = " & LastRow & vbNewLine & "Last column = " & LastCol & vbNewLine & "Address = '" & ws.Name & "'!" & ws.Cells(LastRow, LastCol).Address
    '    MsgBox "Last row = " & LastRow & vbNewLine & "Last column = " & LastCol & vbNewLine & "Address = '" & ws.Name & "'!" & ws.Cells(LastRow, LastCol).Address

    Set LastCell = ws.Cells(LastRow, LastCol)

End Function

Open in new window


hth
Rob
0
 

Author Comment

by:RWayneH
ID: 39744964
aikimark:   Still not finishing with the filter on today and yesterday?  There can just be today, just be yesterday or both on a given day.  (leaving the blanks out )  Can we add something to the end of this that will do this?  Just about there.  Please advise and thanks.

 broro183:  Bob, thanks and yes it is a SAP extract, and we are applying a variant already, however because the extra data is used for various other reports, we needed to extract it all and then go from that extract.. thus we have to strip out all that unneeded stuff for the last report.

  -R-
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39745126
@RWayneH

I'm not sure of your logic.  Please give some examples of single-day processing.
0
 

Author Comment

by:RWayneH
ID: 39745320
At the end of the procedure I have some other macros that run, but do not use the blanks at that time.  The blanks are use later in a whole different report..... long story/explaination.

At this point in the macro, I need it to stop on requested yesterday or today, and/both.  The final output is in V6.  Please finish the macro on that layout.  thanks -R-
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39745331
Have you tested the code I posted?
0
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 

Author Comment

by:RWayneH
ID: 39745368
Yes..  it is just not ending on the correct filter, leaving out the blanks and just leaving everything else after the deletes are done..  It looks like Ln 59 is trying to reset the filter, but it does not.  For some reason it is not leave the data filter as desired.  Can you take a look at Ln 59? or look at why it is not honoring that last filter?  -R-
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39746037
do not set a filter before you run the code
0
 

Author Comment

by:RWayneH
ID: 39746651
It has tested out pretty good so far, I am going to check it for the next couple days to see if it is consistent when new data files come in and it see if it is picking up the correct days..    so far so good.  Thanks. -R-
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39747168
I can tweak the performance a bit more, but it seems to be quite snappy in my testing.
0
 

Author Comment

by:RWayneH
ID: 39748199
Ok it appears to be working to delete the rows, however I need to stop the macro, there and manually select today and yesterdays records (making sure that blanks is unchecked, because the macro is not ending on the correct step.  Then restart another marco from there.

Issue is the last request to have the procedure end at the required spot/selection.
Attached file (V7) is before your code runs, which includes a today and yesterday. (12-30 and 12-31)  My tests on this result with neither of these selected.  I will send a V8 that is a post macro run, showing them unselected...  Are your tests showing the same thing?

Why is the exit point not being honored? -R-
ZGSRF029v7.xlsx
0
 

Author Comment

by:RWayneH
ID: 39748203
Here is the post macro output, no today or yesterday selected.  I see your code cleared filters.  Any ideas? -R-
ZGSRF029v8.xlsx
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39748429
I do not understand.  Your problem (as stated) seems to be solved.  The code will, by default, delete all rows that contain dates for other that yesterday or today, preserving the blank/spaces (non-date) rows, and then apply a filter to show the yesterday/today rows.
0
 

Author Comment

by:RWayneH
ID: 39748661
Notice the difference in the screenshot attached... the blanks are left out of the exit point and are used at another time.  Only today and yesterday are checked so the procedure can continue.  Does that make more sense?  -R-

ScreenShotOfIssue
0
 

Author Comment

by:RWayneH
ID: 39748666
All my testing has produced the same result... nothing in the autofilter in column AG is checked all checkboxes are empty.  Need two of the three checked...  today and yesterday. -R-
0
 

Author Comment

by:RWayneH
ID: 39748690
or is it sorted the correct way? and the autofilter form just does not show that it is?  When I read Ln59 it looks as if it is applying it, but when I click on autofilter dropdown it does not show that way?  Maybe I am missing something here?  -R-
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39748901
It looks like your AG column contains actual dates.  I used 2003 which shows the column contents as text.  If you are getting different results in the autofilter, I would probably attribute it to that difference.  Is it possible that you have done some extra processing on the data?

I see the autofilter dialog difference.  Does this mean that the actual (yesterday and today) date values are not filtered in the column?
0
 

Author Comment

by:RWayneH
ID: 39749001
That was the core of my question.. and the way it looks, it is not filtered, so that is why I need to go in after your code runs and manually check the boxes for today and yesterday.  The icon at the dropdown looks like there is something applied to it, but it does not say or show what?

It is a critical part of the process that blanks stay out of that autofilter, because in the next step I am deleting items based on the today and yesterday filter only.  I am running some more tests, but each test is returning the same... no filter is being applied.  I have not looked specifically for blanks but the next test I will.   Will let you know and thanks. -R-
0
 

Author Comment

by:RWayneH
ID: 39749029
I just tested this again, and for some reason the filter is applied correctly, even though the checkboxes are not checked, the blanks are not there.  I was going by what the autofilter dropdown was saying instead of what was phyiscally in the column...  that is why I was going on on and about it not being filtered correctly....  sorry.

I am going to watch this for a couple days and verify it is working correctly..  thanks -R-
0
 
LVL 10

Expert Comment

by:broro183
ID: 39755954
hi everyone,

RWayneH,
When I run Aikimark's code using excel 2007 I saw the same thing as you have shown in your snippet. I had a closer look & the filter criteria are shown if you click on the "Text Filters". I was able to get the checkboxes to show as being ticked in the first level of the dropdown by changing line 59 from the defining the two inclusions
 ActiveSheet.UsedRange.AutoFilter Field:=33, Criteria1:="=" & dtToday - 1, Operator:=xlOr, Criteria2:="=" & dtToday

Open in new window

to instead define the single exclusion
    wks.UsedRange.AutoFilter Field:=33, Criteria1:="<>          "

Open in new window


Aikimark,
I had initially thought that cell by cell checking would be much slower than other approaches such as Autofilter or using an "in memory array" but after some testing I must admit that my initially thoughts were wrong & your code really is quite snappy :-)
I've had a go at tweaking it & this is what I came up with. Is this similar to how you would tweak it?
(noting that the 0 to 1/2 second improvement means there isn't much of a change in performance in my tweaked version!)
Public Sub Q_28325796_v3(Optional parmDate)
'original version sourced from http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28325796.html#a39744749

Const DelAGIDateCol As Long = 33
Dim dtToday As Date
Dim wks As Worksheet
Dim rng As Range
Dim lngLoop As Long
Dim lngEndRow As Long
Dim lngStartRow As Long
Dim DelAGIDateArr As Variant

    Call ToggleRefreshXlApp(False)

    '    Set wks = Worksheets("ZGSRF029 (2)")
    Set wks = ActiveSheet
    If IsMissing(parmDate) Then
        dtToday = Date
        ''### for testing
        '       dtToday = "28 December 2013"
    Else
        dtToday = parmDate
    End If

    'delete the hyphen row
    Set rng = wks.Range("A1").End(xlDown)
    If rng.Text Like "-*" Then
        rng.EntireRow.Delete
        Set rng = wks.UsedRange
    End If
    '    Application.ScreenUpdating = False

    'sort by the date value column
    rng.Sort key1:=wks.Cells(1, DelAGIDateCol), Header:=xlYes
    DelAGIDateArr = rng.Columns(DelAGIDateCol)
    Set rng = Nothing

    'iterate the AG cells from bottom to top, to identify a single range for deletion.
    'with dates <> yesterday or today
    lngEndRow = UBound(DelAGIDateArr)
    For lngLoop = UBound(DelAGIDateArr) To (LBound(DelAGIDateArr)) Step -1
        Select Case DelAGIDateArr(lngLoop, 1)
            Case dtToday - 1 To dtToday, "          "
                'keep looping
            Case Else
                lngEndRow = lngLoop
                Exit For
        End Select
    Next lngLoop

'NB: if no rows are found that have the multiple spaces, yesterday's or today's date, then
' the header row will be deleted!
'It seems that it will be very unlikely that no records are found (based on the
'example dataset), but if it does happen the absence of headers will be a warning ;-)
'If this is possible, let us know & some error handling can be added.
    Set rng = wks.Range(wks.Rows(2), wks.Rows(lngEndRow))
    '    Application.StatusBar = "Deleted rows: " & rng.Address
    rng.Delete

    'sort by column 1
    wks.Range("A1").CurrentRegion.Sort key1:=wks.Cells(1, 1), Header:=xlYes

    '   Application.ScreenUpdating = True
    '    Application.StatusBar = vbNullString
    'wks.UsedRange.AutoFilter Field:=DelAGIDateCol, Criteria1:=">=" & Format(dtToday - 1, "dd Mmm yyyy"), Operator:=xlAnd, Criteria2:="<=" & Format(dtToday, "dd Mmm yyyy")
    wks.UsedRange.AutoFilter Field:=DelAGIDateCol, Criteria1:="<>          "
    Call ToggleRefreshXlApp(True)
End Sub

Sub ToggleRefreshXlApp(RefreshAppSettings As Boolean, Optional ByRef xlApp As Excel.Application)
    If xlApp Is Nothing Then
        Set xlApp = Excel.Application
    End If
    With xlApp
        If Not RefreshAppSettings Then
            glb_origCalculationMode = .Calculation
            glb_origStatusBar = .StatusBar
        End If
        .EnableEvents = RefreshAppSettings
        On Error Resume Next
        '        .Calculation = IIf(RefreshAppSettings, glb_origCalculationMode, xlCalculationManual)
        .Calculation = IIf(RefreshAppSettings, xlCalculationAutomatic, xlCalculationManual)
        On Error GoTo 0
        .StatusBar = IIf(RefreshAppSettings, vbNullString, CBool(glb_origStatusBar))
        .ScreenUpdating = RefreshAppSettings
    End With
    Set xlApp = Nothing
End Sub

Open in new window


hth
Rob
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39756111
@Rob

My performance tweak would be to invoke a few .Find() methods after sorting the rows by date to establish the ranges I need to keep or delete.  This would be faster than the iteration of the values.  

Also, I might try moving the sorted dates into a variant array and iterating the array and comparing that performance to the .Find() methods.

The big performance boost (so far) was minimizing the number of .Delete methods I invoke.
0
 

Author Closing Comment

by:RWayneH
ID: 39769305
EXCELent!!  thanks.  After a bunch of testing it proved its worth.. Appreciate the help. -R-
0
 
LVL 10

Expert Comment

by:broro183
ID: 39770754
hi guys,

RWayneH,
Thank you for the points but I feel that they should have gone to Aikimark as he provided the first solution,which then evolved.

Thanks Aikimark, since I had already done some testing I thought I may as well carry on & compare the .Find approach with the others :-)
The results surprised me, because I expected .Find() to come out on top. The results showe that the variant array was the fastest as shown by the snippet but it may have been because I didn't implement the .Find very well. The snippet is presented in milliseconds and shows that the variant array approach was ~1/2 a second faster. Less than a second isn't much in the context we've been given, but (at a stretch!), perhaps the speed difference could become significant with a bigger data set, or if iterating through different files/datasets.

speed comparison
Here is the code for the "fastest" one (Q_28325796_v3) that I tried & for one of the variations where I tried to use .find (Q_28325796_v4)
Public Sub Q_28325796_v3(Optional parmDate)
'original version sourced from http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28325796.html#a39744749
'modified to identify row ranges via the use of a variant array.
Const DelAGIDateCol As Long = 33
Dim dtToday As Date
Dim wks As Worksheet
Dim rng As Range
Dim lngLoop As Long
Dim lngEndRow As Long
Dim lngStartRow As Long
Dim DelAGIDateArr As Variant

    Call ToggleRefreshXlApp(False)

    Set wks = Worksheets("ZGSRF029 (2)")
    'Set wks = ActiveSheet
    If IsMissing(parmDate) Then
        dtToday = Date
        ''### for testing
        '       dtToday = "28 December 2013"
    Else
        dtToday = parmDate
    End If

    'delete the hyphen row
    Set rng = wks.Range("A1").End(xlDown)
    If rng.Text Like "-*" Then
        rng.EntireRow.Delete
        Set rng = wks.UsedRange
    End If
    '    Application.ScreenUpdating = False

    'sort by the date value column
    rng.Sort key1:=wks.Cells(1, DelAGIDateCol), Header:=xlYes, order1:=xlDescending, DataOption1:=xlSortTextAsNumbers
    DelAGIDateArr = rng.Columns(DelAGIDateCol)
    Set rng = Nothing

    'iterate the AG cells from bottom to top, to identify a single range for deletion.
    'with dates <> yesterday or today
    lngEndRow = UBound(DelAGIDateArr)
    For lngLoop = UBound(DelAGIDateArr) To (LBound(DelAGIDateArr)) Step -1
        Select Case DelAGIDateArr(lngLoop, 1)
            Case dtToday - 1 To dtToday, "          "
                'keep looping
            Case Else
                lngEndRow = lngLoop
                Exit For
        End Select
    Next lngLoop


    Set rng = wks.Range(wks.Rows(2), wks.Rows(lngEndRow))
    '    Application.StatusBar = "Deleted rows: " & rng.Address
    rng.Delete

    'sort by column 1
    wks.Range("A1").CurrentRegion.Sort key1:=wks.Cells(1, 1), Header:=xlYes

    '   Application.ScreenUpdating = True
    '    Application.StatusBar = vbNullString
    'wks.UsedRange.AutoFilter Field:=DelAGIDateCol, Criteria1:=">=" & Format(dtToday - 1, "dd Mmm yyyy"), Operator:=xlAnd, Criteria2:="<=" & Format(dtToday, "dd Mmm yyyy")
    wks.UsedRange.AutoFilter Field:=DelAGIDateCol, Criteria1:="<>          "
    Call ToggleRefreshXlApp(True)
End Sub

Open in new window


Public Sub Q_28325796_v4(Optional parmDate)
'v4 uses xlprevious
'original version sourced from http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28325796.html#a39744749

Const DelAGIDateCol As Long = 33
Dim dtToday As Date
Dim wks As Worksheet
Dim rng As Range
Dim lngLoop As Long
Dim lngEndRow As Long
Dim lngStartRow As Long
Dim DelAGIDateArr As Variant

Dim FirstBlankCell As Range
Dim FirstYesterdayCell As Range
Dim FirstTodayCell As Range

    '    Call ToggleRefreshXlApp(False)

    Set wks = Worksheets("ZGSRF029 (2)")
    'Set wks = ActiveSheet
    If IsMissing(parmDate) Then
        dtToday = Date
        ''### for testing
        dtToday = "28 December 2013"
    Else
        dtToday = parmDate
    End If

    'delete the hyphen row
    Set rng = wks.Range("A1").End(xlDown)
    If rng.Text Like "-*" Then
        rng.EntireRow.Delete
        Set rng = wks.UsedRange
    End If
    '    Application.ScreenUpdating = False

    'sort by the date value column
    rng.Sort key1:=wks.Cells(1, DelAGIDateCol), Header:=xlYes
    Set rng = rng.Columns(DelAGIDateCol)

    On Error Resume Next
    With rng
        Set FirstYesterdayCell = .Find(What:=CStr(dtToday - 1), After:=.Cells(1, 1), LookIn:=xlFormulas _
                                                                                             , LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
                                       MatchCase:=False, SearchFormat:=False)

        Set FirstTodayCell = .Find(What:="27/12/2013", After:=.Cells(1, 1), LookIn:=xlFormulas _
                                                                                    , LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
                                   MatchCase:=False, SearchFormat:=False)

        Set FirstBlankCell = .Find(What:="          ", After:=.Cells(1, 1), LookIn:=xlFormulas _
                                                                                    , LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                                   MatchCase:=False, SearchFormat:=False)

    End With
    On Error GoTo 0

    Select Case True
        Case Not FirstYesterdayCell Is Nothing
            lngEndRow = FirstYesterdayCell.Row
        Case Not FirstTodayCell Is Nothing
            lngEndRow = FirstTodayCell.Row
        Case Not FirstBlankCell Is Nothing
            lngEndRow = FirstBlankCell.Row
        Case Else
            lngEndRow = rng.Rows.Count
    End Select
    Set rng = wks.Range(wks.Rows(2), wks.Rows(lngEndRow))


    '    DelAGIDateArr = rng.Columns(DelAGIDateCol)
    '    Set rng = Nothing
    '    Stop
    '    'iterate the AG cells from bottom to top, to identify a single range for deletion.
    '    'with dates <> yesterday or today
    '    lngEndRow = UBound(DelAGIDateArr)
    '    For lngLoop = UBound(DelAGIDateArr) To (LBound(DelAGIDateArr)) Step -1
    '        Select Case DelAGIDateArr(lngLoop, 1)
    '            Case dtToday - 1 To dtToday, "          "
    '                'keep looping
    '            Case Else
    '                lngEndRow = lngLoop
    '                Exit For
    '        End Select
    '    Next lngLoop
    '    Set rng = wks.Range(wks.Rows(2), wks.Rows(lngEndRow))
    '    Application.StatusBar = "Deleted rows: " & rng.Address
    rng.Delete

    'sort by column 1
    wks.Range("A1").CurrentRegion.Sort key1:=wks.Cells(1, 1), Header:=xlYes

    '   Application.ScreenUpdating = True
    '    Application.StatusBar = vbNullString
    'wks.UsedRange.AutoFilter Field:=DelAGIDateCol, Criteria1:=">=" & Format(dtToday - 1, "dd Mmm yyyy"), Operator:=xlAnd, Criteria2:="<=" & Format(dtToday, "dd Mmm yyyy")
    wks.UsedRange.AutoFilter Field:=DelAGIDateCol, Criteria1:="<>          "
    '   Call ToggleRefreshXlApp(True)
End Sub

Sub ToggleRefreshXlApp(RefreshAppSettings As Boolean, Optional ByRef xlApp As Excel.Application)
    If xlApp Is Nothing Then
        Set xlApp = Excel.Application
    End If
    With xlApp
        If Not RefreshAppSettings Then
            glb_origCalculationMode = .Calculation
            glb_origStatusBar = .StatusBar
        End If
        .EnableEvents = RefreshAppSettings
        On Error Resume Next
        '        .Calculation = IIf(RefreshAppSettings, glb_origCalculationMode, xlCalculationManual)
        .Calculation = IIf(RefreshAppSettings, xlCalculationAutomatic, xlCalculationManual)
        On Error GoTo 0
        .StatusBar = IIf(RefreshAppSettings, vbNullString, CBool(glb_origStatusBar))
        .ScreenUpdating = RefreshAppSettings
    End With
    Set xlApp = Nothing
End Sub

Open in new window


The following "shared" code has been uploaded before & it may be useful for learning from too. Hopefully the weather stays okay & I haven't missed any supporting code.

Option Explicit
Public glb_origCalculationMode As Long
Public glb_origStatusBar As String
Sub RefreshXlApp()
    With Application
        .EnableEvents = True
        On Error Resume Next
        .Calculation = xlCalculationAutomatic
        On Error GoTo 0
        .StatusBar = False
        .ScreenUpdating = True
        .DisplayFormulaBar = True
        .ExecuteExcel4Macro "SHOW.TOOLBAR(""Ribbon"",True)"
    End With
End Sub
Sub ToggleRefreshXlApp(RefreshAppSettings As Boolean, Optional ByRef xlApp As Excel.Application)
    If xlApp Is Nothing Then
        Set xlApp = Excel.Application
    End If
    With xlApp
        If Not RefreshAppSettings Then
            glb_origCalculationMode = .Calculation
            glb_origStatusBar = .StatusBar
        End If
        .EnableEvents = RefreshAppSettings
        On Error Resume Next
        '        .Calculation = IIf(RefreshAppSettings, glb_origCalculationMode, xlCalculationManual)
        .Calculation = IIf(RefreshAppSettings, xlCalculationAutomatic, xlCalculationManual)
        On Error GoTo 0
        .StatusBar = IIf(RefreshAppSettings, vbNullString, CBool(glb_origStatusBar))
        .ScreenUpdating = RefreshAppSettings
    End With
    Set xlApp = Nothing
End Sub

Open in new window


hth
Rob
0
 
LVL 45

Expert Comment

by:aikimark
ID: 39771230
@Rob

The AG column was treated as text in my environment, so I couldn't approach the solution with as many paths as you.  Thank you for doing that performance testing.
0

Featured Post

IT, Stop Being Called Into Every Meeting

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

Join & Write a Comment

MS Access 2003 or later To MySQL Migration Project Hello All, this is my second article in the category of MS-OFFICE Automation. In internet I am not able to find any comprehensive resource on the Migration of MS Access back-end to MySQL so I fin…
Many companies are making the switch from Microsoft to Google Apps (https://www.google.com/work/apps/business/). Use this article to learn more about what Google Apps has to offer and to help if you’re planning on migrating to Google Apps. It is …
This Micro Tutorial will demonstrate on a Mac how to change the sort order for chart legend values and decrpyt the intimidating chart menu.
This Micro Tutorial will demonstrate how to use longer labels with horizontal bar charts instead of the vertical column chart.

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now