从第二个 sheet 中删除基于日期条件的行并从第三个 sheet 中粘贴到新行中

Question

好吧，我是宏的新手，但我很擅长理解，所以最近完成了相当多的简单工作。主要是修改录制的宏。

让我解释一下我的文件。我不知道如何在这里添加空格或边框，我只是花了 10 分钟谷歌搜索。无论如何，有 3 列：报告日期、部分和 CUSIP。

Sheet 2

Report Date | Section       | CUSIP
-----------------------------------
8/30/2019   | US Sales      | XYZ
8/30/2019   | US Sales      | ABC
8/30/2019   | Foreign Sales | 123
8/30/2019   | Foreign Sales | 456
8/30/2019   | Foreign Sales | 789
8/30/2019   | Foreign Sales | 1011
7/30/2019   | Foreign Sales | 1213
7/30/2019   | US Sales      | EFG
7/30/2019   | US Sales      | HIJ
7/30/2019   | US Sales      | KLM
7/30/2019   | US Sales      | NO14
7/30/2019   | Foreign Sales | 1516P

在 Sheet_1 的单元格 A1 中，有一个我想引用的日期。对于这个例子，假设 Sheet_1 A1 = 9/30/2019.

现在，我需要宏来查看 Sheet_2 列 A 中的数据，并删除日期早于我的参考日期的每一行至少两个月。

所以，如果我在 Sheet_1 A1 中的参考日期是 9/30/2019，那么我需要在 [=55 删除每一行=] 日期为 2019 年 7 月 29 日或之前。

有几千行数据。那么，最有效的方法是什么？

此外，每个月的数据可能会分组在一起...这意味着我不会有一个月与另一月的交替行。

本质上，这只是从 sheet.

中删除 2 个月前的数据

完成后，我需要宏转到 Sheet_3，并从第 2 行复制数据，直到最后一行包含数据它。接下来，它将值粘贴到 Sheet_2 中的第一个空白数据行中。

希望这是清楚的。基本上，换句话说，我有一个 sheet 里面有两个月的数据。如 A 列中的日期所示。每个月，我需要转到此 sheet，删除两个月前的数据，然后粘贴新数据（也就是 [的单元格 A1 中的值） =53=]).

感谢任何帮助

Answer 1

我们将看看我们是否提供了详细信息...

我可能只会在您的真实工作簿的副本上进行测试...

（我相信你也很明显，但我就是不能不说。）

这里是：

Option Explicit ' I Wouldn't go without this...
' It will demand you to declare every variable you use.
' ... without that you may not know why you are having problems...

Sub DataHandling()
    Dim Number_Of_Days_To_Keep As Integer
    Dim Reference_Date_Sht_Name As String
    Dim Data_Store_Sheet_Name As String
    Dim New_Data_Sheet_Name As String

    '-------------------------------------------------------------------------------
    ' Set the number of days, of which data you want to keep...
    Number_Of_Days_To_Keep = 60

    ' Set Sheet Names
    Reference_Date_Sht_Name = "Sheet1"
    Data_Store_Sheet_Name = "Sheet2"
    New_Data_Sheet_Name = "Sheet3"
    '-------------------------------------------------------------------------------

    ' Set Reference Variable to your Workbook
    Dim WB As Workbook
    Set WB = Application.ActiveWorkbook

    ' Set Reference Variables to Worksheets
    Dim RefDateSht As Worksheet
    Dim DataStoreSht As Worksheet
    Dim NewDataSht As Worksheet
    Set RefDateSht = WB.Worksheets(Reference_Date_Sht_Name)
    Set DataStoreSht = WB.Worksheets(Data_Store_Sheet_Name)
    Set NewDataSht = WB.Worksheets(New_Data_Sheet_Name)

    ' Reference Date from Reference Date Sheet
    Dim RefDate As Date
    RefDate = CDate(RefDateSht.Cells(1, "A").Value)

    ' Calculate Cut Off Date from Reference Date and Number Of Days To Keep
    Dim CutOffDate As Date
    CutOffDate = DateAdd("d", -(Number_Of_Days_To_Keep + 1), RefDate)

    ' Last DataStore Row and the DataStore Range
    Dim LastDSRow As Long
    Dim DSRng As Range
    LastDSRow = DataStoreSht.Cells(DataStoreSht.Rows.Count, 1).End(xlUp).Row
    Set DSRng = DataStoreSht.Range(DataStoreSht.Cells(2, "A"), DataStoreSht.Cells(LastDSRow, "X"))

    ' Last NewData Row and the NewData Range
    Dim LastNDRow As Long
    Dim NDRng As Range
    LastNDRow = NewDataSht.Cells(NewDataSht.Rows.Count, 1).End(xlUp).Row
    Set NDRng = NewDataSht.Range(NewDataSht.Cells(2, "A"), NewDataSht.Cells(LastNDRow, "X"))

    ' Support Reference Variables
    Dim Celll As Range
    Dim FirstCutOffCell As Range

    ' Let's see if the Cut Off Date exists in Column 1 of DataStoreSht ...
    Set FirstCutOffCell = DSRng.Columns(1).Cells.Find(What:=Format(CutOffDate, "m/dd/yy"), LookIn:=xlFormulas, Lookat:=xlWhole, SearchDirection:=xlNext)
    If FirstCutOffCell Is Nothing Then
        ' ... if it does not, then check every Row until the Cut Off point is found
        For Each Celll In DSRng.Columns(1).Cells
            If Celll.Value < CutOffDate Then
                Set FirstCutOffCell = Celll
                Exit For
            End If
        Next
    End If

    ' -----------------------------------------------------------------------------------------------------------------------------------
    ' Delete the block of lines which have date before the Cut Off date
    ' -----------------------------------------------------------------------------------------------------------------------------------
    If Not FirstCutOffCell Is Nothing Then
        With DataStoreSht
            .Rows(FirstCutOffCell.Row & ":" & LastDSRow).EntireRow.Delete
            LastDSRow = .Cells(DataStoreSht.Rows.Count, 1).End(xlUp).Row
            Set DSRng = .Range(DataStoreSht.Cells(2, 1), DataStoreSht.Cells(LastDSRow, 3))
        End With
    End If

    ' -----------------------------------------------------------------------------------------------------------------------------------
    ' If there is any New Data on NewDataSht then ...
    ' -----------------------------------------------------------------------------------------------------------------------------------
    If LastNDRow > 1 Then
        ' ... move New Data from NewDataSht to Second Line of DataStoreSht by shifting existing data down.
        NDRng.Copy
        DataStoreSht.Rows(2).EntireRow.Insert Shift:=xlDown
        Application.CutCopyMode = False
    End If
End Sub

从第二个 sheet 中删除基于日期条件的行并从第三个 sheet 中粘贴到新行中

Delete Rows based on Date criteria from second sheet and Paste in New Rows from third sheet

vba

copy-paste