VBA代碼沒有更正所有行數據的日期

Question

我希望你能幫忙。我有一段代碼，它工作得相當好。

它的作用是使用命令按鈕打開一個對話框，該按鈕允許用戶選擇另一張Excel表格後，代碼將合併重複項並創建一個新的行，其中包含儘可能早的開始日期和最新的可能結束日期然後刪除重複的行。

所以在圖片1

我們可以看到，我們有多個開始日期和結束重複的行日期什麼的代碼應該做的是找到的最早開始日期和最晚結束日期的重複，並作出新線。

產品圖1.

PIC的2 你可以看到重複已被刪除和第一個重複的日期是從最早的開始日期和最晚結束日期可能提供Agnholt正確耶爾斯蒂恩起始日期2016年1月4日結束日期17/06/2016

但Breum雷夫其南轅北轍2016年4月5日13/01/2016

產品圖2.

可以修改我的代碼來解決此問題。與往常一樣，任何幫助都不勝感激。

我的代碼如下。

CODE

Sub Open_Workbook_Dialog() 


    Dim strFileName  As String 
    Dim wkb    As Workbook 
    Dim wks    As Worksheet 
    Dim lastRow   As Long 
    Dim r    As Long 

    MsgBox "Select Denmark File" '<--| txt box for prompt to pick a file 

     strFileName = Application.GetOpenFilename(FileFilter:="Excel Files,*.xl*;*.xm*") '<--| Opens the file window to allow selection 

    Set wkb = Application.Workbooks.Open(strFileName) 
    Set wks = ActiveWorkbook.Sheets(1) 
    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 1

通過你的輸出來看，似乎在列H和I的細胞是文本，而不是日期。因此"04/05/2016"小於"13/01/2016"，並且（對於Anders Nyboe Andersen）"15/03/2016"大於"14/03/2016"大於"07/04/2016"。

提供您的語言環境設置是這樣的日期表示爲「dd/mm/yyyy」格式（您的個人資料說愛爾蘭，所以我猜測他們是），您可以通過轉換文本細胞是在執行您比較的前Date：

' Update Start Date on Previous Row 
If CDate(wks.Cells(r, 8)) < CDate(wks.Cells(r - 1, 8)) Then 
    wks.Cells(r - 1, 8) = wks.Cells(r, 8) 
End If 
' Update End Date on Previous Row 
If CDate(wks.Cells(r, 9)) > CDate(wks.Cells(r - 1, 9)) Then 
    wks.Cells(r - 1, 9) = wks.Cells(r, 9) 
End If