VBA根据日期条件创建新行并删除原始行答案

【问题标题】：VBA to create new row and delete original rows based on Date criteriaVBA根据日期条件创建新行并删除原始行
【发布时间】：2017-05-25 05:25:41
【问题描述】：

希望你能帮上忙。

我有一张 Excel 表格，请参阅随附的屏幕截图。我想要达到的就是这个。

我在具有多个开始日期和结束日期的 Excel 工作表中有一些重复的条目。我正在寻找的是一些可以识别重复项的代码，创建一个具有最早可用开始日期和最晚结束日期的新行，然后删除重复行，留下新行

所以在屏幕截图 1 中。

您可以看到第 2 行和第 3 行有一个 Jorgen Steen Agnholt 条目，这些条目的最早开始日期是 01/04/2016，最晚结束日期是17/06/2016

镜头 1。

我需要的只是一个具有最早可用开始日期和最晚可用开始日期的行。

所以这两个条目将合二为一

参见屏幕截图 2。

镜头 2。

与第 7 到 11 行一样 Andres Nyboe Andersen

您可以在屏幕截图 1 中看到他有 5 行数据和多个开始和结束日期，最早开始日期是 14/03/2016，最晚结束日期是 07 /04/2016 我需要的是一行看起来像屏幕截图 3 的数据。

第 3 枪

重复项已被删除，我有一排可以提供最早的开始日期和最晚的结束时间

我知道我没有任何代码，通常我有一些可以利用，但我不知道最好的方法可能是 Autofilter？任何帮助将不胜感激

【问题讨论】：

For x = LastRow to 2 Step -1 并在其上方搜索 Range("B" & x).Value 如果找到，则再次检查直到找不到然后使用 offset 获取最后一个日期并将其向上移动并删除所有非必要的行。至于写代码，SO不是写代码服务。
您可以通过 ADODB 使用 SQL 来执行此操作。

标签： vba excel date filtering

【解决方案1】：

您可以使用 SQL 和聚合函数 MIN 和 MAX：

Option Explicit

Sub SqlAggregateFunctionsTest()

    Dim strConnection As String
    Dim strQuery As String
    Dim objConnection As Object
    Dim objRecordSet As Object

    Select Case LCase(Mid(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".")))
        Case ".xls"
            strConnection = "Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;Data Source='" & ThisWorkbook.FullName & "';Mode=Read;Extended Properties=""Excel 8.0;HDR=YES;"";"
        Case ".xlsm", ".xlsb"
            strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source='" & ThisWorkbook.FullName & "';Mode=Read;Extended Properties=""Excel 12.0 Macro;HDR=YES;"";"
    End Select

    strQuery = "SELECT [Surname], [First Name], [Place of employment], [Address], [Postcode], [City], [CPR no], " & _
        "MIN([Start date]) AS [Start date], MAX([End date]) AS [End date] " & _
        "FROM [Sheet1$] " & _
        "GROUP BY [Surname], [First Name], [Place of employment], [Address], [Postcode], [City], [CPR no]"

    Set objConnection = CreateObject("ADODB.Connection")
    objConnection.Open strConnection
    Set objRecordSet = objConnection.Execute(strQuery)
    RecordSetToWorksheet Sheets(2), objRecordSet
    objConnection.Close

End Sub

Sub RecordSetToWorksheet(objSheet As Worksheet, objRecordSet As Object)

    Dim i As Long

    With objSheet
        .Cells.Delete
        For i = 1 To objRecordSet.Fields.Count
            .Cells(1, i).Value = objRecordSet.Fields(i - 1).Name
        Next
        .Cells(2, 1).CopyFromRecordset objRecordSet
        .Cells.Columns.AutoFit
    End With

End Sub

我用Sheet1上的源数据测试了代码：

我在Sheet2 上的输出如下：

该方法的唯一限制是 ADODB 连接到驱动器上的 Excel 工作簿，因此在查询之前应保存任何更改以获得实际结果。

【讨论】：

【解决方案2】：

Public Sub ConsolidateDupes()
    Dim wks As Worksheet
    Dim lastRow As Long
    Dim r As Long

    Set wks = Sheet1

    lastRow = wks.UsedRange.Rows.Count

    For r = lastRow To 3 Step -1
        ' Identify Duplicate
        If wks.Cells(r, 1) = wks.Cells(r - 1, 1) _
        And wks.Cells(r, 2) = wks.Cells(r - 1, 2) _
        And wks.Cells(r, 3) = wks.Cells(r - 1, 3) _
        And wks.Cells(r, 4) = wks.Cells(r - 1, 4) _
        And wks.Cells(r, 5) = wks.Cells(r - 1, 5) _
        And wks.Cells(r, 6) = wks.Cells(r - 1, 6) _
        And wks.Cells(r, 7) = wks.Cells(r - 1, 7) Then
            ' Update Start Date on Previous Row
            If wks.Cells(r, 8) < wks.Cells(r - 1, 8) Then
                wks.Cells(r - 1, 8) = wks.Cells(r, 8)
            End If
            ' Update End Date on Previous Row
            If wks.Cells(r, 9) > wks.Cells(r - 1, 9) Then
                wks.Cells(r - 1, 9) = wks.Cells(r, 9)
            End If
            ' Delete Duplicate
            Rows(r).Delete
        End If
    Next
End Sub

【讨论】：

谢谢！！谢谢！！一千次谢谢你，这是有效的。都柏林爱尔兰非常尊重。 :-)

【解决方案3】：

也许不是问题的确切解决方案，但很接近。您可以使用数据透视表为您完成大部分工作。

为清楚起见，请在电子表格中包含一列，设置为 =CONCATENATE(C1, " ", ", A1) 以提供完整名称
然后，选择您的表格并创建一个数据透视表
将计算的名称列用作行
使用开始日期作为列并将值设置为开始日期的最小值
您需要将数据透视表列格式化为日期
对结束日期执行相同操作，但选择将值设置为结束日期的最大值
设置格式为短日期。

您从中得到的是一个每人 1 行的数据透视表，其中包含 MIN(START) 和 MAX (END)。然后，您可以根据需要使用它来做其他事情。

如果您不想使用数据透视表并使用 VBA 宏或其他可行的方法，但这应该比编写 VBA 代码更快。

【讨论】：