突出显示满足条件的一系列日期
Highlight series of dates that met conditions
我在 excel sheet 中有一个数据，其中包含客户 ID、结果日期和一些实验室测试的结果。每个客户的日期按升序排序。我想要一个 VBA 代码来检查每个客户的日期并测试 每个日期之间的差异 是否 不超过 2 个月 并找到 最长的连续日期集 并 用颜色突出显示 它，例如黄色。这组日期不一定是最早的或最新的，但应该是持续时间最长的不间断日期2个月以上。
此外，如果在结果列旁边为那个长集计算持续时间，那就太好了，这样我们就可以相应地对数据进行排序。
这是我的文件 link。
以下是该要求的屏幕截图。
image for the excel sheet
从链接文件中提取的示例数据
+----+----------+------------------------+---------+
| # | A | B | C |
+----+----------+------------------------+---------+
| 1 | ClientId | Results Date & Time | Results |
+----+----------+------------------------+---------+
|... | ... | ... | ... |
+----+----------+------------------------+---------+
|105 | 1 | 12/06/2018 12:42:00 PM | 1.9 |
+----+----------+------------------------+---------+
|106 | 1 | 6/25/2018 1:55:00 PM | 1.8 |
+----+----------+------------------------+---------+
|107 | 2 | 3/29/2016 9:11:00 AM | 1 |
+----+----------+------------------------+---------+
|108 | 2 | 6/8/2016 12:50:00 PM | 2 |
+----+----------+------------------------+---------+
|...
通过数据字段数组解决
"I want a VBA code to go through the dates of every client and test if the difference between every date is not more than 2 months and to find the longest consecutive set of dates and highlight it with color, yellow for example"
范围内的循环总是耗时，因此我通过数据字段数组演示了一种方法，而不是简化2 个月条件 到 天差异 <= 64 天 因为我不想让这个例子过于复杂。
由于"the dates are sorted ascending for each client"，很容易查到下一个Client id，计算日差，添加到当前duration 变量并将其与记忆变量进行比较，以便在同一 id 中找到最长的一组日期，然后更改为下一个 id。
最后将结果写入 概览数组 以收集要 突出显示 的项目编号。这可以通过 条件格式
来完成
此外，我在代码模块的声明头中集成了一个 Enum 声明，只是为了显示有意义的变量而不是纯数字的使用（此处替换数组 'column' 数字）。
0。代码模块的声明头
严格建议使用 Option Explicit 强制变量的类型声明，从而避免明显无法解释的类型不匹配或其他问题。
如果您使用从定义的第一个元素开始的自动枚举，则已经提到的 Enum 声明还有另一个功能，例如[_Zero]：您可以轻松重组内部顺序，而无需更改仅包含纯数字的每一行代码。
提示：所有 Enum 元素都使用 IntelliSense 显示，[] 括号中的元素和以下划线字符 _ 开头的元素名称除外。
小改动 08/28 <-- Edit #100 --> 当前编辑不枚举 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# -->) 和最终错误 13 在第 III b) 部分写回持续时间。
编辑 3: 请参阅第二部分中对 非数字 项的额外检查（<-- 编辑 14# 和 15# - ->)
编辑4：原来的方法没有假设数据行数超过65,536是绝对的限制 使用 ►Index 函数（试图在此处隔离数组列）。
这个最终编辑希望避免 Error 13 Type mismatch 使用额外的数组 d 和所有相关的持续时间数据（定义的 2 个月范围内的累积天数差异）并纠正一些其他小问题。在第 II 节 <-- Edit #101 --> 和第 III 节 <-- Edit #102 to #122 -->
中进行了更正
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
可选的结果显示
如果你想在单独的 sheet "Overview" 中显示找到的项目数据，你可以将此添加到上面的代码中：
' 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. $XFD48576 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:
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
我在 excel sheet 中有一个数据，其中包含客户 ID、结果日期和一些实验室测试的结果。每个客户的日期按升序排序。我想要一个 VBA 代码来检查每个客户的日期并测试 每个日期之间的差异 是否 不超过 2 个月 并找到 最长的连续日期集 并 用颜色突出显示 它，例如黄色。这组日期不一定是最早的或最新的，但应该是持续时间最长的不间断日期2个月以上。
此外，如果在结果列旁边为那个长集计算持续时间，那就太好了，这样我们就可以相应地对数据进行排序。
这是我的文件 link。 以下是该要求的屏幕截图。 image for the excel sheet
从链接文件中提取的示例数据
+----+----------+------------------------+---------+
| # | A | B | C |
+----+----------+------------------------+---------+
| 1 | ClientId | Results Date & Time | Results |
+----+----------+------------------------+---------+
|... | ... | ... | ... |
+----+----------+------------------------+---------+
|105 | 1 | 12/06/2018 12:42:00 PM | 1.9 |
+----+----------+------------------------+---------+
|106 | 1 | 6/25/2018 1:55:00 PM | 1.8 |
+----+----------+------------------------+---------+
|107 | 2 | 3/29/2016 9:11:00 AM | 1 |
+----+----------+------------------------+---------+
|108 | 2 | 6/8/2016 12:50:00 PM | 2 |
+----+----------+------------------------+---------+
|...
通过数据字段数组解决
"I want a VBA code to go through the dates of every client and test if the difference between every date is not more than 2 months and to find the longest consecutive set of dates and highlight it with color, yellow for example"
范围内的循环总是耗时，因此我通过数据字段数组演示了一种方法，而不是简化2 个月条件 到 天差异 <= 64 天 因为我不想让这个例子过于复杂。
由于"the dates are sorted ascending for each client"，很容易查到下一个Client id，计算日差，添加到当前duration 变量并将其与记忆变量进行比较，以便在同一 id 中找到最长的一组日期，然后更改为下一个 id。
最后将结果写入 概览数组 以收集要 突出显示 的项目编号。这可以通过 条件格式
来完成此外，我在代码模块的声明头中集成了一个 Enum 声明，只是为了显示有意义的变量而不是纯数字的使用（此处替换数组 'column' 数字）。
0。代码模块的声明头
严格建议使用 Option Explicit 强制变量的类型声明，从而避免明显无法解释的类型不匹配或其他问题。
如果您使用从定义的第一个元素开始的自动枚举，则已经提到的 Enum 声明还有另一个功能，例如[_Zero]：您可以轻松重组内部顺序，而无需更改仅包含纯数字的每一行代码。
提示：所有 Enum 元素都使用 IntelliSense 显示，[] 括号中的元素和以下划线字符 _ 开头的元素名称除外。
小改动 08/28 <-- Edit #100 --> 当前编辑不枚举 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# -->) 和最终错误 13 在第 III b) 部分写回持续时间。
编辑 3: 请参阅第二部分中对 非数字 项的额外检查（<-- 编辑 14# 和 15# - ->)
编辑4：原来的方法没有假设数据行数超过65,536是绝对的限制 使用 ►Index 函数（试图在此处隔离数组列）。
这个最终编辑希望避免 Error 13 Type mismatch 使用额外的数组 d 和所有相关的持续时间数据（定义的 2 个月范围内的累积天数差异）并纠正一些其他小问题。在第 II 节 <-- Edit #101 --> 和第 III 节 <-- Edit #102 to #122 -->
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
可选的结果显示
如果你想在单独的 sheet "Overview" 中显示找到的项目数据，你可以将此添加到上面的代码中：
' 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. $XFD48576 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:
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