Delete row based on current date before saving

Question

I have a macro-heavy form/spreadsheet that I need to delete rows where col D has the date before the current date whenever the sheet is saved.
In other words, if column D has a row with Feb 20(2/20/2014) then the VBA will delete that row and shift the cells up because the date is earlier than today's date. Below is the code in 'ThisWorkbook' which exports an XML exactly the way I need it to but the code added at the bottom only works when I remove all the other code, there has to be a way to perform both these functions before saving. Also the code to remove the dated rows removes any empty cells as well which I would like to prevent.

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)


'ThisWorkbook.Close SaveChanges:=True this will save on close, not sure if needed yet

Dim colIndex As Integer
Dim rwIndex As Integer
Dim asCols() As String
Dim oWorkSheet As Worksheet
Dim sName As String
Dim lCols As Long, lRows As Long
Dim iFileNum As Integer
Dim str_switch As String ' To use first column as node
Dim blnSwitch As Boolean

'--------Set WorkSheet and Columns and Rows

Set oWorkSheet = ThisWorkbook.Worksheets("Data")
sName = oWorkSheet.Name
lCols = oWorkSheet.Columns.Count
lRows = oWorkSheet.Rows.Count

ReDim asCols(lCols) As String

iFileNum = FreeFile
Open "C:\test.xml" For Output As #iFileNum

'move through columms

For i = 1 To lCols - 1

If Trim(oWorkSheet.Cells(2, i + 1).Value) = "" Then Exit For
    asCols(i) = oWorkSheet.Cells(2, i + 1).Value
Next i

If i = 0 Then GoTo ErrorHandler
    lCols = i

Print #iFileNum, "<?xml version=""1.0""?>"
Print #iFileNum, "<" & sName & ">" ' add sheet name to xml file as First Node

'----------------------------------------------------------------
 str_switch = "SDFSDKF" ' to trip loop

For i = 3 To lRows

    If Trim(oWorkSheet.Cells(i, 2).Value) = "" Then
        Exit For
    End If

Debug.Print oWorkSheet.Cells(i, 2).Value
    If str_switch <> oWorkSheet.Cells(i, 2).Value Then
        If blnSwitch = True Then
            Print #iFileNum, "</" & "Data" & ">"
        End If

            Print #iFileNum, "<" & "Data" & ">"
            Print #iFileNum, " <" & asCols(1) & ">" & Trim(oWorkSheet.Cells(i, 2).Value) & "</"  & asCols(1) & ">"
            blnSwitch = True
    Else

    End If
            Print #iFileNum,
            For j = 3 To lCols
                Print #iFileNum, " <" & asCols(j - 1) & ">" & Trim(oWorkSheet.Cells(i, j).Value) & "</" & asCols(j - 1) & ">"
            Next j

            Print #iFileNum,
     str_switch = oWorkSheet.Cells(i, 2).Value
    Next i

    '------------End & close File --------------------
    Print #iFileNum, "</" & "Data" & ">"
    Print #iFileNum, "</" & sName & ">"

    Close #iFileNum


 ErrorHandler:
   If iFileNum > 0 Then Close #iFileNum
   Exit Sub

 With Sheets("Main")
    LR = .Cells(Rows.Count, "D").End(xlUp).Row
    For i = LR To 2 Step -1
    If .Cells(i, "D").Value < Date Then
        .Rows(i).EntireRow.Delete
    End If
  Next i
 End With

  End Sub

Which part of the bottom of your code that is not working? Also What is not working? — Alex
You need to reverse the functionality..........move the row delete coding before the save coding. — Gary's Student
With Sheets("Main") LR = .Cells(Rows.Count, "D").End(xlUp).Row For i = LR To 2 Step -1 If .Cells(i, "D").Value < Date Then .Rows(i).EntireRow.Delete End If Next i End With — user3357423
Gary's Student - reversing the functionality does remove the desired cells, but it also removes all blank cells which is a problem. What can I add to stop that? Not to mention it also causes an error with the XML code. — user3357423

Roger Barreto Roger Barreto · Accepted Answer · 2014-02-27T20:43:59

First! Put the Exit Sub inside the End If Code, That way it is not in the ErrorHandler condition... this will prevent the exiting before running end code !

Change the handler to this:

ErrorHandler:
   If iFileNum > 0 Then 
       Close #iFileNum
       Exit Sub
   End If

You also dont need to specify the EntireRow because its not a Selection, as you are already in the context of your worksheet. You should also specify that want to shitcells UP after the delete.

Modified to not delete Empty Dates

With Sheets("Main")
    LR = .Cells(Rows.Count, "D").End(xlUp).Row
    For i = LR To 2 Step -1
    If Not IsEmpty(.Cells(i, "D").Value) AND .Cells(i, "D").Value < Date Then
        .Rows(i).Delete  Shift:=xlUp
    End If
  Next i
End With

Delete row based on current date before saving

1 Answers