通过数据字段数组解决
“我想要一个 VBA 代码检查每个客户的日期并测试每个日期之间的差异是否不超过 2 个月，并找到最长的连续日期集并用颜色突出显示它，例如黄色”
循环遍历一个范围总是耗时，所以我通过数据字段数组演示了一种方法，而不是将2个月条件简化为天差异 因为我不想让这个例子过于复杂。
由于“每个客户的日期按升序排列”，因此很容易检查下一个客户 ID，计算日差，将它们添加到当前持续时间变量中，然后将其与记住的变量进行比较，以找到同一 id 中最长的一组日期，然后更改为下一个 id。
最后将结果写入概览数组以收集要突出显示的项目编号。这可以通过条件格式
来完成
此外，我在代码模块的声明头中集成了一个 Enum 声明，只是为了显示使用有意义的变量而不是纯数字（此处替换数组“列”数字）。
0。代码模块的声明头
强烈建议使用Option Explicit 强制声明变量的类型，从而避免明显无法解释的类型不匹配或其他问题。
如果您使用从定义的第一个元素开始的自动枚举，那么已经提到的Enum 声明还有另一个功能，例如[_Zero]：您可以轻松地重构内部顺序，而无需更改仅包含纯数字的每一行代码。
提示：所有 Enum 元素都使用 IntelliSense 显示，[] 括号中的元素和以下划线字符 _ 开头的元素名称除外。
小改动 08/28 当前编辑没有枚举 data.Results 而不影响想要的输出，因为所有 data 成员都会自动重新编号+1 的额外增量（在[_Zero]=0 之后计算）。
Option Explicit ' force declaration of variables
' assign meaningful number variables for your array columns
Enum data ' automatically enumerates column numbers 1 to 5 (-> array v)
[_Zero] = 0
Id
Date
days
Duration
End Enum
Enum Ov ' automatically enumerates column numbers 1 to 6 (-> array overview)
[_Zero] = 0
Id
StartDate
EndDate
duration
StartItem
enditem
End Enum
1.主程序GetLongestDuration()
编辑 1： 我将所有计算的日期变量的 Type 从 Long 更改为 Double（即 maxDAYS#、currDuration#、memDuration#）以防止类型不匹配，尤其是在计算中断天数。
编辑 2： 请参阅第 II 部分中的更改以避免 空日期 计算（例如，在评论中提到的最后一行）（ ) 和最终错误 13 在第 III b) 节中写回持续时间。
编辑 3：请参阅第 II 部分中对非数字项的额外检查（）
编辑 4： 原始方法没有假设数据行数超过 65,536 的数量，这是使用 ► 的绝对限制 Index 函数（尝试在此处隔离数组列）。
希望最终的编辑避免了 Error 13 Type mismatch 使用带有所有相关持续时间数据的额外数组 d（在定义的 2 个月范围内累积的天数差异），并纠正了其他一些小问题。在第二节 和第三节
中进行了更正
Sub GetLongestDuration()
' Purpose: Highlight longest set of dates <= 64 days
' Condition: Client IDs and Dates are sorted in ascending order.
' Edit 8/16: Enumerated type changes of maxDAYS#, currDuration#, memDuration# changed to DOUBLE (#)
' Edit 8/17: Edit in section II <-- Edit #13 -->
' Edit 8/22: Edit in section II <-- Edit #14 and #15 -->
' Edit 8/28: Edit in section II <-- Edit #101 -->, section III <-- Edit #102 to #122 -->
Const maxDAYS# = 64# ' << <--#1 Double--> change maximal difference to next date
Const DATASHEET$ = "LABs and Diagnostics" ' << replace with your data sheet name
Const OVSHEET$ = "Overview" ' << replace with your Overview sheet name
Const OVTITLES$ = "ID,Start Date,End Date,Duration,Start Item, End Item"
' declare variables
Dim ws As Worksheet, ws2 As Worksheet ' declare object variables as worksheet
Set ws = ThisWorkbook.Worksheets(DATASHEET) ' set data sheet object to memory
Dim v As Variant, overview As Variant ' variant datafield array and results array
Dim Id As String ' current state
Dim StartItem As Long
Dim StartDate As Double, EndDate As Double '
Dim days As Double, currDuration As Double ' <-- #2 Double -->
Dim memStartDate#, memEndDate# ' remember highest findings
Dim memDuration# ' <-- #3 Double -->
Dim memStartItem&, memLastItem& ' remember highest findings
Dim i As Long, ii As Long, n As Long, iOv As Long ' counters
' 0. get last row number n and assign values to a 2-dim array v
ws.Columns("D:D") = "" ' clear column D (duration)
n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 2 ' find last row number n plus 2 more rows
v = ws.Range("A2:E" & n).Value2 ' create 2-dim datafield array omitting headers
ReDim overview(1 To n, 1 To 6) ' create a helper array with results
' =======================
' loop through data array
' =======================
' remember first ID (for later comparation with changing array item id)
Id = v(1, data.Id) & ""
For i = LBound(v) To UBound(v) ' loop through items 1 to items count UBound(v) in data array v
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' I. check new ID in first 'column' of each array item
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If v(i, data.Id) & "" & "" <> Id Then ' check current id against remembered id
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'... complete analytics of preceding id in overview
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If i > 1 Then
ii = ii + 1
overview(ii, Ov.Id) = Id
overview(ii, Ov.StartDate) = memStartDate
overview(ii, Ov.EndDate) = memEndDate
overview(ii, Ov.Duration) = memDuration
overview(ii, Ov.StartItem) = memStartItem
overview(ii, Ov.enditem) = memLastItem
Else
overview(ii, Ov.StartItem) = 1
End If
'... and switch to new current id
Id = v(i, data.Id) & ""
currDuration = 0#: memDuration = 0# ' <-- #4 Double --> reset to zero
memStartItem = 0&: memLastItem = 0&
End If
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' II. calculate days and check coherent periods
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If i < UBound(v) Then ' stop calculation one item before last item row
If Len(Trim(v(i + 1, data.Date))) = 0 Then ' avoid type mismatch if empty
days = 0#
ElseIf Not IsNumeric(v(i, data.Date)) Then ' <-- #14 not numeric -->
days = 0#
MsgBox "Item no " & i & " " & v(i, data.Date) & " is not numeric!"
Else
If IsNumeric(v(i + 1, data.Date)) Then ' <-- #15 not numeric -->
days = v(i + 1, data.Date) - v(i, data.Date) ' get days difference to next date
v(i, data.days) = days ' <-- #101 remind days difference -->
End If
End If
Else ' there's nothing more to add
days = 0# ' <-- #5 Double -->
End If
' avoid negative day counts in last row
If days < 0 Then days = 0# ' <-- #6 Double -->
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' a) days till next date within two months (i.e. <=64)
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If days <= maxDAYS And days > 0 Then
v(i, data.days) = days ' assign days to column 5
currDuration = currDuration + days ' add days in current set to cumulated duration
If i > 1 Then
If v(i - 1, data.days) = 0 Then
StartItem = i ' StartItem number in current data set
StartDate = v(i, data.Date) ' StartDate current data set
End If
End If
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' b) days till next date exceed two months
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Else
v(i, data.days) = 0# ' <-- #7 Double --> therefore no count
' if longer duration then remember this set within current id
If currDuration > memDuration Then
memDuration = currDuration
memStartDate = StartDate
memEndDate = v(i, data.Date)
memStartItem = StartItem
memLastItem = i
End If
' start new set
currDuration = 0# ' <-- #8 Double --> reset to zero
End If
Next i
v(UBound(v), data.days) = 0# ' <-- #9 Double --> days in last row
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' III. calculate durations for longest coherent periods and write it to new column D
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' a) loop through all overview items
Dim d: ReDim d(1 To UBound(v), 1 To 1) ' <-- #102 create separate duration array -->
If overview(1, Ov.enditem) > 0 Then overview(1, Ov.StartItem) = 1 ' <-- #103 set startitem of 1st to 1 if relevant date range -->
For iOv = 1 To ii
currDuration = 0# ' <-- #10 Double --> reset to 0 (Double!)
''' If overview(iOv, Ov.StartItem) = 0 Then Exit For ' <-- #104 DELETE last Edit #0/Aug 14th 18) -->
memStartItem = overview(iOv, Ov.StartItem) ' <-- #105 remember start item -->
If memStartItem = 0 Then ' <-- #106/107/108 clear not relevant dates -->
overview(iOv, Ov.StartDate) = "" '
overview(iOv, Ov.EndDate) = "" '
Else ' <-- #109 relevant dates -->
''' v(overview(iOv, Ov.StartItem), data.Duration) = 0# ' <-- #110 DELETE last Edit #11 Double -->
d(memStartItem, 1) = currDuration ' <-- #111 write current duration to array -->
For i = memStartItem To overview(iOv, Ov.enditem) - 1 ' <-- #112 first item no to last item no -->
currDuration = currDuration + CDbl(v(i, data.days)) ' <-- #12 CDbl --> add days to cumulated sum currDuration
v(i + 1, data.Duration) = currDuration ' <-- #113 (unchanged) --> assign duration to source array v in column 4
d(i + 1, 1) = currDuration ' <-- #114
Next i ' <-- #115 (unchanged) -->
End If ' <-- #116 closing IF to #106 -->
Next iOv ' <-- #117 (unchanged) -->
' b) write cumulated duration into column D
' **********************************************************
' avoid ERROR 13 type mismatch, ii 6379 **ISSUE 2018/08/22**
' **********************************************************
' Caveat: Index function (trying to isolate single array column) has limitation to 65,536 rows only!
''' ws.Range("D2").Resize(UBound(v), 1) = Application.Index(v, 0, data.Duration) <-- #118 uncomment/DELETE -->
ws.Range("D2").Resize(UBound(d), 1) = d ' <-- #119 write relevant durations to column D -->
ws.Range("D1") = "Duration" ' <-- #120 add title -->
ws.Range("D:D").NumberFormat = "# ??/24" ' <-- #121 fraction format shows days + hours -->
' IV. set Conditional Format in order to highlight found items (condition: existing value in column D)
' (calls helper function SetConditionalFormat with arguments range and condition)
SetConditionalFormat ws.Range("A:D"), "=LEN(TRIM($D1 & """"))>0" ' <--#122 (unchanged) -->
' V. optional display of results in sheet 'Overview', see below
End Sub
结果的可选显示
如果您想在单独的“概览”表中显示找到的项目数据，您可以将其添加到上面的代码中：
' V. optional display of separate Overview sheet with results
' a) add Overview sheet if it doesn't exist yet
If Not SheetExists(OVSHEET) Then
With ThisWorkbook.Worksheets.Add
.Name = OVSHEET ' baptize it e.g. "Overview"
.Columns("B:C").NumberFormat = "dd/mm/yyyy;@" ' << change columns B:C do wanted local format
End With
End If
Set ws2 = ThisWorkbook.Worksheets(OVSHEET) ' set overview sheet object to memory
' b) write titles and results to Overview sheet
ws2.Range("A:F") = "" ' clear columns
ws2.Range("A1:F1") = Split(OVTITLES, ",") ' write titles to overview!A1:F1
If ii < 1 Then
ws2.Range("A2") = "No duration sets identified!"
Else
ws2.Range("A2").Resize(ii, UBound(overview, 2)) = overview ' write array overview back to Overview sheet
End If
2。帮助程序SetConditionalFormat()
此过程在主过程的 [IV.] 部分中调用，并突出显示 D 列中包含数据的所有单元格的已找到日期集。一种可能的情况是询问修剪后的字符串长度是否为零。 国际使用：必须考虑到条件格式（CF）需要►本地公式 - 因此集成了辅助函数getLocalFormula()。 *
Sub SetConditionalFormat( _
ByRef rng As Range, _
ByVal sFormula As String, _
Optional ByVal myColor As Long = 65535, _
Optional bDelFormerFormats As Boolean = True)
' Author: T.M.
' Purpose: set conditional format to given range using sFormula
' Note: former formats are deleted by default unless last argument isn't set to False
' Hint: Formula1 always needs the LOCAL formula, so the string argument sFormula
' has to be translated via helper function getLocalFormula() using a work around
With rng
' a) delete existing conditional formats in A:D
If bDelFormerFormats Then .FormatConditions.Delete
' b) add new condition with needed LOCAL formula
.FormatConditions.Add _
Type:=xlExpression, _
Formula1:=getLocalFormula(sFormula) ' << get local formula via helper function
.FormatConditions(.FormatConditions.Count).SetFirstPriority
With .FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.color = myColor ' yellow by default parameter
.TintAndShade = 0
End With
.FormatConditions(1).StopIfTrue = False
End With
End Sub
3 a) 辅助函数getLocalFormula()
此函数由上述辅助过程调用，因为条件格式总是需要本地公式，因此考虑国际化：
Function getLocalFormula(ByVal sFormula As String) As String
' Author: T.M.
' Purpose: work around to translate English formula to local formula
' Caveat: assumes there is no value in last cell (e.g. $XFD$1048576 in more recent versions)
With ActiveSheet.Range("A1").Offset(ActiveSheet.Rows.Count - 1, ActiveSheet.Columns.Count - 1)
' assign formula to temporary cell in order to get local formula string
.Formula = sFormula
' get local formula
getLocalFormula = .FormulaLocal
.Value = "" ' delete temporary formula
End With
End Function
3 b) 辅助函数SheetExists()
由主过程的可选部分 [V.] 调用：
Function SheetExists(SheetName As String, Optional wb As Workbook) As Boolean
' Author: Tim Williams
' Purpose: check if worksheet exists (returns True or False)
' cf Site: https://stackoverflow.com/questions/6688131/test-or-check-if-sheet-exists
Dim ws As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set ws = wb.Worksheets(SheetName)
On Error GoTo 0
SheetExists = Not ws Is Nothing
End Function