根據保存前的當前日期刪除行

我有一個宏大的表格/電子表格，我需要刪除行，其中col 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

來源

2014-02-27 user3357423

你的代碼不工作底部的哪一部分？另外**什麼**不工作？ – Alex

您需要反轉功能..........在**保存**編碼之前移動行刪除編碼**。 –

不工作的部分是... – user3357423

首先！將Exit Sub放在End If代碼中，這樣它就不會處於ErrorHandler狀態......這將阻止在運行結束代碼之前退出！

更改的處理程序是：

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

您也不需要指定EntireRow，因爲它不是一個選擇，因爲你已經在你工作的環境。您還應該指定想要在刪除後拔出電池。

修改爲不刪除空日期

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

來源

2014-02-27 20:43:59

根據保存前的當前日期刪除行

回答

相關問題