VBA创build新行并根据date标准删除原始行

我希望你能帮上忙。

我有一个Excel工作表，看附加的屏幕截图。 我想要达到的是这个。

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

所以在屏幕截图1。

你可以看到第2行和第3行有Jorgen Steen Agnholt的条目，这些条目的最早开始date是01/04/2016 ，最近的结束date是17/06/2016

射击1。

我需要的是只有一行有可能的最早的开始date和最新的可能的开始date。

所以这两个条目将成为一个

见屏幕截图2。

射击2。

像明智的行7至11 Andres Nyboe Andersen

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

射击3

重复已被删除，我有一行的最早的开始date和最新的结束可能

我知道我没有任何代码通常我有一些杠杆作用，但我很难找出最好的办法或许自动filter？ 任何帮助将不胜感激

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

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

1. 为了清晰起见，请在电子表格中包含一列，设置为= CONCATENATE（C1，“”，“，A1），以提供完整的名称
2. 然后，select你的表并创build一个数据透视表
3. 使用计算的名称列作为行
4. 使用开始date作为列， 并将值设置为开始date的MIN
5. 您需要将数据透视表列的格式设置为date
6. 对结束date做同样的事情，但是select将值设置为结束date的最大值
7. 将格式设置为短date。

你从中得到什么是一个数据透视表每行1人与MIN（开始）和最大（结束）。 然后，您可以根据需要使用它来做其他事情。

如果你不想使用数据透视表，并使用VBAmacros或可行的东西，但这应该比写VBA代码更快。

Answer 3

您可以使用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上的源数据testing了代码：

我在Sheet2上的输出如下：

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