VBA創建新行並根據日期條件刪除原始行

我希望你能提供幫助。VBA創建新行並根據日期條件刪除原始行

我有一張excel表單，請參閱附加的屏幕截圖。我試圖達到的是這個。

我有一些Excel表格中有多個開始日期和結束日期的重複條目。我所尋找的是一些代碼，可以識別重複，創建一個新的行可用的最早開始日期和最晚結束日期可用，則刪除重複行，留下了新行

所以在屏幕截圖1

你可以看到行2和3對約爾根·斯蒂恩Agnholt最早開始日期爲這些條目的條目是2016年1月4日和最新的結束日期17/06/2016

拍攝1.

我需要的只是一行有最早可用的開始日期和最新的可用開始日期。

所以這兩個項目將成爲一個

見截圖2

命中2

像明智的行7至11 安德烈斯Nyboe安徒生

你可以在屏幕截圖1中看到他有5行數據和多個開始和結束日期，最早的開始日期是14/03/201 6和最新的結束日期是2016年7月4日我需要的是看起來像拍攝畫面中的一行數據3.

射擊3

的副本已被刪除我有一排最早的開始日期和最新的結束可能

我知道我沒有任何代碼通常我有一些槓桿作用，但我很難找出最好的辦法或許自動過濾器？任何幫助將不勝感激

來源

2017-01-10 Philip Connell

對於x = LastRow to 2 Step -1並搜索範圍（「B」＆x）。在上面的值，如果你找到它，然後再次檢查，直到它找不到它，然後使用偏移量來抓取最後一個日期並將其移動並刪除所有不必要的行。至於編寫代碼，SO不是代碼寫入服務。 – Chrismas007

您可以通過ADODB使用SQL來完成此操作。 – omegastripes

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

來源

2017-01-10 17:05:58

謝謝！謝謝！！千次感謝你的工作。來自愛爾蘭都柏林的尊重。 :-) –

也許不是一個確切的解決方案的問題，但接近。您可以使用數據透視表爲您完成大部分工作。

爲清晰起見，在您的電子表格，設置爲= CONCATENATE列（C1，「」，」 A1）給你的全名
然後，選擇你的表，並創建一個數據透視表
使用計算的名稱列行
使用開始起作爲柱，設置值設置到MIN開始日期
你需要的數據透視表列格式的日期
執行結束日期的相同事項，但選擇將值設置設置爲結束日期的最大值
將格式設置爲短日期。

你從中得到的是一個數據透視表，每人1行，MIN（START）和MAX（END）。然後，您可以根據需要使用它來完成其他任務。

如果您不想使用數據透視表並使用VBA宏或其他可行的東西，但這應該會比編寫該VBA代碼更快。

來源

2017-01-10 16:54:10 dgorti

您可以使用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工作簿，因此在查詢之前應保存所有更改以獲取實際結果。

來源

2017-01-10 19:28:23 omegastripes

VBA創建新行並根據日期條件刪除原始行

回答

相關問題