Question

我希望你能提供帮助。

我有一张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？任何帮助将不胜感激

Answer 1

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

Answer 2

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

为清楚起见，请在电子表格中添加一列，设置为= CONCATENATE（C1，＆＃34;＆＃34;，＆＃34;，A1），以便为您提供完整的名称
然后，选择您的表并创建一个数据透视表
将计算出的名称列用作行
使用开始日期作为列，将值设置设置为开始日期的最小值
您需要将数据透视表列格式化为日期
对结束日期执行相同操作，但选择将值设置设为结束日期的MAX
将格式设置为短日期。

你得到的是每人一个数据透视表1行MIN（START）和MAX（END）。然后，您可以根据需要使用它来执行其他操作。

如果您不想使用数据透视表并使用VBA宏或可行的东西，但这应该比编写VBA代码更快地接近您。

Answer 3

您可以使用SQL和汇总函数UID和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输出如下：

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

VBA根据日期条件

3 个答案: