VBA代码不能更正所有行数据的date

我希望你能帮上忙。 我有一段代码，它工作得相当好。

它的作用是打开一个对话框，使用命令button，允许用户select另一个excel工作表，然后合并重复项，并创build一个新的行，尽可能早的开始date和最后的可能的结束date然后删除重复的行。

所以在图1

我们可以看到，具有多个开始date和结束date的行重复，代码应该做的是find具有最早的开始date和最后的结束date的重复项，并创build一个新的行。

图1。

在图2中，您可以看到副本已被删除，第一个副本的date是正确的，可能有最早的开始date和最后结束dateAgnholtJørgenSteen开始date01/04/2016结束date17/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列中的单元格似乎是文本，而不是date。 因此"04/05/2016"小于"13/01/2016" ，和（为安德斯Nyboe安徒生） "15/03/2016"大于"14/03/2016"大于"07/04/2016" 。

提供您的语言环境设置是这样的date表示为“dd / mm / yyyy”格式（您的configuration文件说爱尔兰，所以我猜测他们是），您可以通过将单元格中的文本转换为执行比较之前的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