VBA 代码未更正所有数据行的日期

Question

希望你能帮上忙。我有一段代码，效果比较好。

它的作用是使用命令按钮打开一个对话框，允许用户在选择此工作表后选择另一个 Excel 工作表，然后合并重复项并创建一个具有最早可能开始日期和最新开始日期的新行可能的结束日期然后删除重复的行。

所以在图 1 中

我们可以看到我们有多个开始日期和结束日期的重复行，代码应该做的是找到具有最早开始日期和最晚结束日期的重复行并创建一个新行。

图1。

在图 2 您可以看到重复项已被删除，并且对于第一个重复项，日期是正确的，最早的开始日期和最晚的结束日期可能可用 Agnholt Jørgen Steen 开始日期 01/04/2016 结束日期 17/06/2016

但是对于 Breum Leif 来说，它的方式是错误的 04/05/2016 13/01/2016

图 2。

能否修改我的代码以解决此问题。一如既往地非常感谢任何帮助。

我的代码如下。

代码

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