MS Excel VBA Code - Simplest Way to Check if a Series of Dates is Between Two Dates and Enter Comment and Date in another Column

O

OilEconomist

Active Member
Joined
Dec 26, 2016
Messages
421
Office Version
  1. 2019
Platform
  1. Windows
Thanks in advance for any responses. What is the simplest and most efficient way to write VBA Code to check if a series of dates (columns A and B within "Sheet1") are within the dates (Columns B and C) of each row in "Sheet2" and add a comment if it is. The following is the VBA Code I wrote which works, but I would like to see if there is a simpler method. It runs fairly fast, but the data set is small. I thought about storing the data sets in Sheet1 into Scripting Dictionaries, but not sure how to retrieve and compare.

VBA Code: 
Option Explicit
'***************************************************************************************************************
Sub DateRangeCheck()

 '_______________________________________________________________________________________________________
 'Turn off alerts, screen updates, and automatic calculation
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Application.Calculation = xlManual
            
            
  '_______________________________________________________________________________________________________
  'Dimensioning
  
    'Dim Longs
     Dim i As Long, j As Long, NoSL As Long, NLR_Sht2 As Long
    
    
    'Dim Strings
     Dim Sht1 As String, Sht2 As String
     Dim DataSet As String, CommentStr As String
     
     
    'Dim Dates
     Dim DateStart As Date, DateEnd As Date
     
     
    'Dim Ranges
     Dim aCell As Range, Rng As Range, Rng_Sht1_DS1 As Range, Rng_Sht1_DS2 As Range
 
 
    'Dim Timer Variables
     Dim BenchMark As Double
 
 
 
  '_______________________________________________________________________________________________________
  'Code - Timer Benchmark
    BenchMark = Timer
    
 
 '_______________________________________________________________________________________________________
  'Code - set sheet names
    
    Sht1 = "Sheet1"
    Sht2 = "Sheet2"


    
  '_______________________________________________________________________________________________________
  'Code -
    
    NLR_Sht2 = LastRowF(Sht2)
    
    With Sheets(Sht2)
        .Range("C" & NLR_Sht2).Clear
    End With



  '_______________________________________________________________________________________________________
  'Code -

    With Sheets(Sht1)
        Set Rng_Sht1_DS1 = .Range(.Cells(9, 1), .Cells(24, 1))
        Set Rng_Sht1_DS2 = .Range(.Cells(9, 2), .Cells(32, 2))
    End With
    
    

  '_______________________________________________________________________________________________________
  'Code -
  
    NoSL = 9 'starting row for the loop
    NLR_Sht2 = LastRowF(Sht2) 'last row for the loop
    
    With Sheets(Sht2)
     
     For j = 1 To 2
        
        If j = 1 Then
            Set Rng = Rng_Sht1_DS1
            DataSet = "DATA SET 1"
        ElseIf j = 2 Then
            Set Rng = Rng_Sht1_DS2
            DataSet = "DATA SET 2"
        End If
        
        NoSL = 9
        
        For Each aCell In Rng
        
            For i = NoSL To NLR_Sht2
                DateStart = .Cells(i, 1)
                DateEnd = .Cells(i, 2)
                CommentStr = .Cells(i, 3)
                
                'Check if date is within start and end dates
                 If Not IsEmpty(DateStart) And aCell < DateStart Then
                    Exit For
                 ElseIf Not IsEmpty(DateStart) And aCell >= DateStart And aCell <= DateEnd Then
                       
                    'Add the comment, but preserve prior comments
                     If CommentStr <> "" Then
                        CommentStr = CommentStr & " & " & DataSet & ": " & Format(aCell.Value, "YYYY-MM-DD, DDD")
                        .Cells(i, 3) = CommentStr
                     Else
                        CommentStr = DataSet & ": " & Format(aCell.Value, "YYYY-MM-DD, DDD")
                        .Cells(i, 3) = CommentStr
                     End If
                    
                     NoSL = i
                     Exit For
                    
                End If
                
            Next i
            
        Next aCell
        
     Next j
     
    End With
    
    
    
  '_______________________________________________________________________________________________________
  'Place cursor in Workbook, Sheet, and Cell
 
 
 
  '_______________________________________________________________________________________________________
  'Turn on alerts and screen updates, and calculate
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Calculate


 
  '_______________________________________________________________________________________________________
  'Timer
  
    MsgBox Round(Timer - BenchMark, 2)



  '_______________________________________________________________________________________________________
  'End of the subroutine/macro
 

End Sub

"Sheet1"
Test Date Pull.xlsx
AB
8DATE SET 1DATE SET 2
9 2021-01-26, Tue 2021-01-13, Wed
10 2021-03-16, Tue 2021-02-10, Wed
11 2021-04-27, Tue 2021-03-16, Tue
12 2021-06-15, Tue 2021-04-13, Tue
13 2021-07-27, Tue 2021-05-12, Wed
14 2021-09-21, Tue 2021-06-10, Thu
15 2021-11-02, Tue 2021-07-13, Tue
16 2021-12-14, Tue 2021-08-11, Wed
17 2022-01-25, Tue 2021-09-14, Tue
18 2022-03-15, Tue 2021-10-13, Wed
19 2022-05-03, Tue 2021-11-10, Wed
20 2022-06-14, Tue 2021-12-10, Fri
21 2022-07-26, Tue 2022-01-12, Wed
22 2022-09-20, Tue 2022-02-10, Thu
23 2022-11-01, Tue 2022-03-10, Thu
24 2022-12-13, Tue 2022-04-12, Tue
25 2022-05-11, Wed
26 2022-06-10, Fri
27 2022-07-13, Wed
28 2022-08-10, Wed
29 2022-09-13, Tue
30 2022-10-13, Thu
31 2022-11-10, Thu
32 2022-12-13, Tue
Sheet1


"Sheet2" before running the code
Test Date Pull.xlsx
ABC
8DATEDATECOMMENT
92021-03-08, Mon2021-03-12, Fri
102021-03-15, Mon2021-03-19, Fri
112021-03-22, Mon2021-03-26, Fri
12
132021-06-07, Mon2021-06-11, Fri
142021-06-14, Mon2021-06-18, Fri
152021-06-21, Mon2021-06-25, Fri
16
172021-09-07, Tue2021-09-10, Fri
182021-09-13, Mon2021-09-17, Fri
192021-09-20, Mon2021-09-24, Fri
20
212021-12-06, Mon2021-12-10, Fri
222021-12-13, Mon2021-12-17, Fri
232021-12-20, Mon2021-12-23, Thu
24
252022-03-07, Mon2022-03-11, Fri
262022-03-14, Mon2022-03-18, Fri
272022-03-21, Mon2022-03-25, Fri
28
292022-06-06, Mon2022-06-10, Fri
302022-06-13, Mon2022-06-17, Fri
312022-06-21, Tue2022-06-24, Fri
32
332022-09-06, Tue2022-09-09, Fri
342022-09-12, Mon2022-09-16, Fri
352022-09-19, Mon2022-09-23, Fri
Sheet2


"Sheet2" after running the code
Test Date Pull.xlsx
ABC
8DATEDATECOMMENT
92021-03-08, Mon2021-03-12, Fri
102021-03-15, Mon2021-03-19, FriDATA SET 1: 2021-03-16, Tue & DATA SET 2: 2021-03-16, Tue
112021-03-22, Mon2021-03-26, Fri
12
132021-06-07, Mon2021-06-11, FriDATA SET 2: 2021-06-10, Thu
142021-06-14, Mon2021-06-18, FriDATA SET 1: 2021-06-15, Tue
152021-06-21, Mon2021-06-25, Fri
16
172021-09-07, Tue2021-09-10, Fri
182021-09-13, Mon2021-09-17, FriDATA SET 2: 2021-09-14, Tue
192021-09-20, Mon2021-09-24, FriDATA SET 1: 2021-09-21, Tue
20
212021-12-06, Mon2021-12-10, FriDATA SET 2: 2021-12-10, Fri
222021-12-13, Mon2021-12-17, FriDATA SET 1: 2021-12-14, Tue
232021-12-20, Mon2021-12-23, Thu
24
252022-03-07, Mon2022-03-11, FriDATA SET 2: 2022-03-10, Thu
262022-03-14, Mon2022-03-18, FriDATA SET 1: 2022-03-15, Tue
272022-03-21, Mon2022-03-25, Fri
28
292022-06-06, Mon2022-06-10, FriDATA SET 2: 2022-06-10, Fri
302022-06-13, Mon2022-06-17, FriDATA SET 1: 2022-06-14, Tue
312022-06-21, Tue2022-06-24, Fri
32
332022-09-06, Tue2022-09-09, Fri
342022-09-12, Mon2022-09-16, FriDATA SET 2: 2022-09-13, Tue
352022-09-19, Mon2022-09-23, FriDATA SET 1: 2022-09-20, Tue
Sheet2
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
Here is what I came up with. Best, probably not. But it does what you asked for.

VBA Code: 
Sub DateWithinDatesComment()

'   Range object used for datasets 1 & 2
    Dim rDataSet As Range
    
'   Range points to start date cells
    Dim rStartDates As Range
    
'   Count of data cells in the range.
    Dim iDataCells As Long
    
'   Two range objects used for looping ranges
    Dim rCellDataSet As Range
    Dim rCellDateCheck As Range
    
'   Three date values: date to test, start and end dates
    Dim dTestDate As Date
    Dim dStartDate As Date
    Dim dEndDate As Date
    
'   Used to copy comments from dataset one. If there is a dataset
'   two entry then need to preserve the dataset 1 comment.
    Dim sCommentDataSet1 As String
    
'   Range where start dates reside.
    With Worksheets("Sheet2")
        iDataCells = Application.WorksheetFunction.CountA(.Columns(2)) - 1
        Set rStartDates = .Range("A1").Offset(1).Resize(iDataCells)
    End With
    
'   Range containing dataset 1.
    With Worksheets("Sheet1")
        iDataCells = Application.WorksheetFunction.CountA(.Columns(1)) - 1
        Set rDataSet = .Range("A1").Offset(1).Resize(iDataCells)
    End With

'   Clear existing comments -- offset two columns from start dates.
    rStartDates.Cells(1).Offset(1, 2).Resize(iDataCells).Value = ""

'   Process dataset 1.
    For Each rCellDataSet In rDataSet
    
        dTestDate = CDate(rCellDataSet.Value)
        
        For Each rCellDateCheck In rStartDates
            dStartDate = CDate(rCellDateCheck.Value)
            dEndDate = CDate(rCellDateCheck.Offset(, 1).Value)
           
            If dTestDate >= dStartDate And dTestDate <= dEndDate _
             Then
                rCellDateCheck.Offset(, 2).Value = "Dataset 1, " & Format(dTestDate, "m/d/yyyy, ddd")
            End If
            
        Next rCellDateCheck
    
    Next rCellDataSet

'   Range for dataset 2.
    With Worksheets("Sheet1")
        iDataCells = Application.WorksheetFunction.CountA(.Columns(2)) - 1
        Set rDataSet = .Range("B1").Offset(1).Resize(iDataCells)
    End With

'   Process dataset 2
    For Each rCellDataSet In rDataSet
    
        dTestDate = CDate(rCellDataSet.Value)
        
        For Each rCellDateCheck In rStartDates
            dStartDate = CDate(rCellDateCheck.Value)
            dEndDate = CDate(rCellDateCheck.Offset(, 1).Value)
           
            If dTestDate >= dStartDate And dTestDate <= dEndDate _
             Then
             
'               Preserve dataset 1 comment.
                sCommentDataSet1 = rCellDateCheck.Offset(, 2).Value

'               If there is a dataset 1 comment then ad ampersand to the end
'               in preparation for add dataset 2 comment.
                If sCommentDataSet1 <> "" Then sCommentDataSet1 = sCommentDataSet1 & " & "
                
'               Put comment into the comment cell. Two columns over from the start dates column.
                rCellDateCheck.Offset(, 2).Value = sCommentDataSet1 & "Dataset 2, " & Format(dTestDate, "m/d/yyyy, ddd")
            
            End If
            
        Next rCellDateCheck
    
    Next rCellDataSet

End Sub
 
Upvote 0
OaklandJim said:
Here is what I came up with. Best, probably not. But it does what you asked for.

VBA Code: 
Sub DateWithinDatesComment()

'   Range object used for datasets 1 & 2
    Dim rDataSet As Range
   
'   Range points to start date cells
    Dim rStartDates As Range
   
'   Count of data cells in the range.
    Dim iDataCells As Long
   
'   Two range objects used for looping ranges
    Dim rCellDataSet As Range
    Dim rCellDateCheck As Range
   
'   Three date values: date to test, start and end dates
    Dim dTestDate As Date
    Dim dStartDate As Date
    Dim dEndDate As Date
   
'   Used to copy comments from dataset one. If there is a dataset
'   two entry then need to preserve the dataset 1 comment.
    Dim sCommentDataSet1 As String
   
'   Range where start dates reside.
    With Worksheets("Sheet2")
        iDataCells = Application.WorksheetFunction.CountA(.Columns(2)) - 1
        Set rStartDates = .Range("A1").Offset(1).Resize(iDataCells)
    End With
   
'   Range containing dataset 1.
    With Worksheets("Sheet1")
        iDataCells = Application.WorksheetFunction.CountA(.Columns(1)) - 1
        Set rDataSet = .Range("A1").Offset(1).Resize(iDataCells)
    End With

'   Clear existing comments -- offset two columns from start dates.
    rStartDates.Cells(1).Offset(1, 2).Resize(iDataCells).Value = ""

'   Process dataset 1.
    For Each rCellDataSet In rDataSet
   
        dTestDate = CDate(rCellDataSet.Value)
       
        For Each rCellDateCheck In rStartDates
            dStartDate = CDate(rCellDateCheck.Value)
            dEndDate = CDate(rCellDateCheck.Offset(, 1).Value)
          
            If dTestDate >= dStartDate And dTestDate <= dEndDate _
             Then
                rCellDateCheck.Offset(, 2).Value = "Dataset 1, " & Format(dTestDate, "m/d/yyyy, ddd")
            End If
           
        Next rCellDateCheck
   
    Next rCellDataSet

'   Range for dataset 2.
    With Worksheets("Sheet1")
        iDataCells = Application.WorksheetFunction.CountA(.Columns(2)) - 1
        Set rDataSet = .Range("B1").Offset(1).Resize(iDataCells)
    End With

'   Process dataset 2
    For Each rCellDataSet In rDataSet
   
        dTestDate = CDate(rCellDataSet.Value)
       
        For Each rCellDateCheck In rStartDates
            dStartDate = CDate(rCellDateCheck.Value)
            dEndDate = CDate(rCellDateCheck.Offset(, 1).Value)
          
            If dTestDate >= dStartDate And dTestDate <= dEndDate _
             Then
            
'               Preserve dataset 1 comment.
                sCommentDataSet1 = rCellDateCheck.Offset(, 2).Value

'               If there is a dataset 1 comment then ad ampersand to the end
'               in preparation for add dataset 2 comment.
                If sCommentDataSet1 <> "" Then sCommentDataSet1 = sCommentDataSet1 & " & "
               
'               Put comment into the comment cell. Two columns over from the start dates column.
                rCellDateCheck.Offset(, 2).Value = sCommentDataSet1 & "Dataset 2, " & Format(dTestDate, "m/d/yyyy, ddd")
           
            End If
           
        Next rCellDateCheck
   
    Next rCellDataSet

End Sub
Click to expand...
Thanks so much for this. It shows me some alternative programming methods that I intend to use.

I tested it and it works. I compared run times and my code came a bit faster, but nothing noticeable. Check the beginning of my code and end to see how do to it if you are not familiar with it.
If you can post your code with the following changes and check to make sure it gives the same as my data set, I will then mark it as the solution.
(1) The data in both "Sheet1" and "Sheet2" starts in row 9 with row 8 as the heading. I think you start in either row 1 or 2. Can you update this.
(2) If the cells are blank, don't do anything in those rows. Right now, it is putting values in the comments section.

These two I would not ask you to change, but if you are going to change the aforementioned, will you also change this. This will allow a user to compare my output to what you get running your code and to quickly see that it gives the exact output.
(2) Change the date formatting to "YYYY-MM-DD, DDD".
(3) Change "Data Set 1" and "Data Set 2" to "DATA SET 1: " and "DATA SET 2: " respectively.
 
Upvote 0
This code works with variable array not with cells in worksheet, it might help code faster
VBA Code: 
Option Explicit
Sub DateRangeCheck()
Dim lr&, i&, j&, rng1, rng2
Dim set1 As String

'store date value of sheet 1 in variable
With Sheets("Sheet1")
    lr = .UsedRange.Rows.Count + 7
    rng1 = .Range("A9:B" & lr).Value2
End With

'store date value of sheet 2 in variable
With Sheets("Sheet2")
    lr = .Cells(Rows.Count, "A").End(xlUp).Row
    rng2 = .Range("A9:C" & lr).Value2
    
    'loop through each row of sheet2
    For i = 1 To UBound(rng2)
        If rng2(i, 1) <> "" And rng2(i, 2) <> "" Then
            set1 = "" ' set1: to store text string combination
            For j = 1 To UBound(rng1)
                       
                'check date range of data set 1 then write into set1
                If rng1(j, 1) <> "" And rng1(j, 1) >= rng2(i, 1) And rng1(j, 1) <= rng2(i, 2) Then
                    set1 = IIf(set1 = "", "DATA SET 1: ", ", " & set1 & "& ") & Format(rng1(j, 1), "yyyy-mm-dd, ddd")
                End If
                
                'check date range of data set 2 then combine into set1
                If rng1(j, 2) <> "" And rng1(j, 2) >= rng2(i, 1) And rng1(j, 2) <= rng2(i, 2) Then
                    set1 = set1 & IIf(set1 = "", "", " & ") & "DATA SET 2: " & Format(rng1(j, 2), "yyyy-mm-dd, ddd")
                End If
            Next
                  
        'write text string into variable, column 3
            rng2(i, 3) = set1 ' & set2
        End If
    Next
    .Range("A9:C" & lr).Value = rng2 ' paste variable back to sheet
End With
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

M
  • Solved
Formula Help.
Replies
3
Views
60
Fluff
Fluff
C
  • Solved
Extract Dates from 2 columns
Replies
2
Views
309
Peter_SSs
Peter_SSs
A
  • Solved
Returning a single result for a match under certain criteria
Replies
5
Views
382
ATHlaptop
A
SaraWitch
  • Solved
Return first Monday in April from one date and first Monday in current year April if another is blank
2 3
Replies
28
Views
831
Dave Patton
D
G
  • Solved
Splitting Dates with Unique ID
Replies
6
Views
411
Akuini
Akuini

Forum statistics

Threads
1,214,957
Messages
6,122,466
Members
449,086
Latest member
kwindels

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top