问题
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.
Here is a link to my file. and below is a screenshot for the requirement. image for the excel sheet
Example data extracted from linked file
+----+----------+------------------------+---------+
| # | 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 |
+----+----------+------------------------+---------+
|...
回答1:
Solution via datafield array
"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"
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.
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
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. Declaration head of your code module
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.
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.
Hint: All Enum elements are displayed using IntelliSense with exception of elements in [] brackets and element names starting with an underline character _.
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. Main procedure GetLongestDuration()
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.
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).
Edit 3: See additional check for non-numeric items in section II (<-- Edit 14# and 15# -->)
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).
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
Optional Display of results
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. Helper procedure SetConditionalFormat()
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) 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) Helper function SheetExists()
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
来源：https://stackoverflow.com/questions/51751330/highlight-series-of-dates-that-met-conditions