突出显示满足条件的一系列日期 [英] Highlight series of dates that met conditions
问题描述
我在excel工作表中有一个数据，其中包含客户端ID，结果日期和一些实验室测试的结果。每个客户的日期按升序排列。我希望VBA代码能检查每个客户的日期，并测试每个日期之间的差异是否不超过2个月，并找出最长的连续时间一组日期和 Highlight 颜色（例如黄色）。这组日期不一定是最旧的或最新的，但应是不间断日期的最长持续时间超过2个月。
I have a data in excel sheet that contains client id, date of a result and the result of some lab tests. The dates are sorted ascending for each client. 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. This set of date is not necessarily to be the oldest or the newest, but should be the longest duration of non interrupted date by more than 2 months.
此外，如果为结果列旁边的那个长集计算持续时间，那就太好了，因此我们可以对数据进行相应的排序。
Also, it would be great if the duration is calculated for that long set next to the result column, so we can sort the data accordingly.
这是链接我的档案。
及以下是该要求的屏幕截图。
Excel工作表的图像
从链接文件中提取的示例数据
+----+----------+------------------------+---------+
| # | 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 |
+----+----------+------------------------+---------+
|...
推荐答案
通过数据字段阵列的解决方案
我希望VBA代码能够遍历每个客户端的日期并测试每个日期之间的差异是否不超过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天，因为我不想让这个示例过于复杂。
Loops through a range are always time consuming, so I demonstrate an approach via a datafield array instead simplifying the 2-months condition to day differences <= 64 days as I didn't want to overcomplicate this example.
由于日期按每个客户的升序排列 ，因此很容易查看下一个客户ID ，计算日差，将其添加到当前持续时间变量中，然后将其与记住的变量进行比较，以找到同一ID内最长的日期集，然后更改为下一个ID。
As "the dates are sorted ascending for each client", it's easy to check the next Client id, calculate day differences, add them in a current duration variable and compare it with remembered variables in order to find the longest set of dates within the same id, then changing to the next id.
最后将结果写入概览数组，以收集要突出显示的项目编号。这可以通过条件格式
Finally results are written to an overview array to collect the item numbers to be highlighted. This can be done via conditional formatting
完成。此外，我在 Enum 声明中集成了代码模块的声明头只是为了显示有意义的变量而不是纯数字的使用（此处替换为数组列数字）。
Furthermore I integrate an Enum declaration in the declaration head of your code module just to show the use of meaningful variables instead of pure numbers (replacing here array 'column' numbers).
0。代码模块的声明头
强烈建议使用 Option Explicit 进行类型声明
It's strictly recommanded to use Option Explicit to make the type declaration of variables obligatory thus avoiding apparently unexplainable type mismatches or other issues.
已经提到的 Enum 声明还有另一个功能，那就是避免出现无法解释的类型不匹配或其他问题。您正在使用从定义的第一个元素开始的自动枚举，例如[_Zero]：您可以轻松地重组内部顺序，而无需更改每个仅包含纯数字的代码行。
The already mentioned Enum declaration has another feature if you are using the automatic enumeration starting from a defined first element, e.g. [_Zero]: you can easily restructure the internal order without changing every code line containing only pure numbers.
提示：所有 Enum 元素都使用IntelliSense显示，但 _ 开头。
Hint: All Enum elements are displayed using IntelliSense with exception of elements in [] brackets and element names starting with an underline character _.
较小更改08/28<-编辑＃100-> 当前编辑不会枚举 data.Results 而不会影响所需的输出，因为所有数据成员都自动重新编号，并且增加了+1（在 [_ Zero] = 0 ）。
Minor change 08/28 <-- Edit #100 --> The current edit does without enumerating data.Results without influencing the wanted output, as all data members are renumbered automatically with an additional increment of +1 (calculated after [_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. Main procedure GetLongestDuration()
编辑1：从长到 Double 的所有计算日变量的类型（例如maxDAYS＃，currDuration＃，memDuration＃）以防止类型不匹配，尤其是在计算休息日时。
Edit 1: I changed the Type of all calculated day variables from Long to Double (i.e. maxDAYS#, currDuration#, memDuration#) to prevent type mismatches, especially when calculating broken days.
编辑2：请参阅第二节中的更改，以避免计算空日期（例如，如注释）（<-编辑13＃->），并最终在第III b）节中写回错误13。
Edit 2: See changes in section II to avoid empty date calculation (e.g. in last row as mentioned in comment) (<-- Edit 13# -->) and eventual error 13 writing back durations in section III b).
编辑3：请参见第二节中对非数字项的其他检查（<-编辑14 ＃和15＃->）
Edit 3: See additional check for non-numeric items in section II (<-- Edit 14# and 15# -->)
编辑4：原始方法没有假定数据行超过了 65,536 是使用► Index 函数的绝对限制（尝试在此处隔离数组列）。
Edit 4: The original approach didn't assume that data rows exceeded the number of 65,536 being the absolute Limitation to use the ►Index function (trying to isolate an array column here).
希望最终的编辑使用额外的数组 d <可以避免错误13类型不匹配 / code>以及所有相关的持续时间数据（在定义的2个月范围内的累计日差），并更正了其他一些小问题。更正的内容在第二部分<-编辑＃101->和第三部分<-编辑＃102至＃122->
This hopefully final edit avoids an Error 13 Type mismatch using an extra array d with all relevant duration data (cumulated day differences within the defined 2 month range) and corrects some other minor issues. Corrections are made in section II <-- Edit #101 --> and section 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
可选的结果显示
如果要单独显示找到的项目数据工作表概述，您可以将其添加到上面的代码中：
If you want to display the found item data in a separate sheet "Overview", you could add this to the code above:
' 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（）
2. Helper procedure SetConditionalFormat()
此过程在主程序的[IV。]部分中调用步骤并突出显示D列中所有包含数据的单元格的找到的日期集。一种可能的条件是询问修剪后的字符串长度是否等于零。 国际使用：必须考虑条件格式（CF）需要►本地公式-因此有一个辅助功能 *
This procedure is called in section [IV.] of the main procedure and highlights the found date sets for all cells in column D containing data. One possible condition is to ask if the trimmed string length equals zero. International use: It has to be considered that conditional format (CF) requires ►local formulae - therefore a helper function getLocalFormula() is integrated.*
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（）
3 a) Helper function getLocalFormula()
此函数由上述帮助程序调用，因为条件格式始终需要本地公式，因此请考虑国际化：
This function is called by the above helper procedure, as conditional formatting always needs the local formula thus considering internationalization:
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（）
3 b) Helper function SheetExists()
由主过程的可选部分[V.]调用：
Called by optional section [V.] of the main procedure:
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
这篇关于突出显示满足条件的一系列日期的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
![Excel工作表的图像](\"https://i.stack.imgur.com/8ridB.jpg\"){kind=link}