保存前根据当前日期删除行答案

【问题标题】：Delete row based on current date before saving保存前根据当前日期删除行
【发布时间】：2014-10-25 16:02:20
【问题描述】：

我有一个宏观繁重的表单/电子表格，每当保存工作表时，我都需要删除列 D 的日期早于当前日期的行。
换句话说，如果 D 列有一行Feb 20(2/20/2014)，那么 VBA 将删除该行并将单元格向上移动，因为日期早于今天的日期。下面是“ThisWorkbook”中的代码，它完全按照我需要的方式导出 XML，但底部添加的代码仅在我删除所有其他代码时才有效，必须有一种方法在保存之前执行这两个功能。此外，删除日期行的代码也会删除任何我想阻止的空单元格。

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

【问题讨论】：

您的代码底部的哪一部分不起作用？还有什么不起作用？
你需要反转功能............移动行删除编码之前保存编码。跨度>
不工作的部分是……
With Sheets("Main") LR = .Cells(Rows.Count, "D").End(xlUp).Row For i = LR To 2 Step -1 If .Cells(i, "D").Value
Gary 的学生 - 反转功能确实会删除所需的单元格，但它也会删除所有空白单元格，这是一个问题。我可以添加什么来阻止它？更不用说它还会导致 XML 代码出错。

标签： excel file-io vba

【解决方案1】：

首先！将Exit Sub 放在 End If 代码中，这样它就不在 ErrorHandler 条件下...这将防止在运行结束代码之前退出！

将处理程序更改为：

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

您也不需要指定 EntireRow，因为它不是选择，因为您已经在工作表的上下文中。您还应该指定要在删除后将shitcells UP。

修改为不删除空日期

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

【讨论】：