CODEWITHSUNDEEP
vbaexcel
doublea
doublea

Reputation: 11

Check if date falls between some range

I have data that is similar to:

A1: ID
B1: Start date
C1: End Date

I have another worksheet (call it New) that has

A1: ID and 
B1: Date

I need to find out if the date for the ID in New worksheet was already in the previous Worksheet. If the date is start date, end date or anything in between, I want it to show that there is a record that already exist.

Upvotes: 0

Views: 3175

Answers (3)

PatricK
PatricK

Reputation: 6433

Solution here assuming something more practical:

  • A Master sheet with ID, Start Date, End Date (multiple rows)
  • Other sheets with ID and Date (multiple rows)
  • Uses a User Defined Function (UDF) and the ID cell as input
  • One drawback is that you will need "Calculate Sheet" if other sheets has been updated

Sample screenshots:
Formula for Sheet1 D2: =FindDuplicates(A2)

Sheet1Sheet2Sheet3

Code in a Module:

Option Explicit

Function FindDuplicates(oRngID As Range) As String
    Dim sID As String, dStart As Date, dEnd As Date, lCount As Long, sWhere As String
    Dim oWS As Worksheet, oRngFound As Range, dFound As Date, sFirstFound As String

    sID = oRngID.Text
    dStart = oRngID.Offset(0, 1).Value
    dEnd = oRngID.Offset(0, 2).Value
    lCount = 0
    sWhere = ""
    For Each oWS In ThisWorkbook.Worksheets
        ' Find all IDs in other worksheeets
        If oWS.Name <> oRngID.Worksheet.Name Then
            sFirstFound = ""
            Set oRngFound = oWS.Cells.Find(What:=sID)
            If Not oRngFound Is Nothing Then
                sFirstFound = oRngFound.Address
                ' Keep searching until the first found address is met
                Do
                    ' Check the dates, only add if within the dates
                    dFound = oRngFound.Offset(0, 1).Value
                    If dStart <= dFound And dFound <= dEnd Then
                        lCount = lCount + 1
                        If lCount = 1 Then
                            sWhere = sWhere & lCount & ")  '" & oWS.Name & "'!" & oRngFound.Address
                        Else
                            sWhere = sWhere & vbCrLf & lCount & ")  '" & oWS.Name & "'!" & oRngFound.Address
                        End If
                    End If
                    Set oRngFound = oWS.Cells.Find(What:=sID, After:=oRngFound)
                Loop Until oRngFound.Address = sFirstFound
            End If
        End If
    Next
    If lCount = 0 Then sWhere = "Not Found"
    FindDuplicates = Replace(sWhere, "$", "") ' Removes the $ sign in Addresses
End Function

Upvotes: 1

John Bustos
John Bustos

Reputation: 19574

I kinda liked this question...

The way I would do it would be using the SUMPRODUCT() function to check for multiple criteria (there are many references both on this site and Google explaining how that works)

In your New worksheet, assuming the first row is for headers, in cell C2 put in the following formula:

=SUMPRODUCT(--(Sheet1!$A$2:$A$180=A2),--((B2-Sheet1!$B$2:$B$180)>=0),--((Sheet1!$C$2:$C$180-B2)>=0)) > 0

And drag it down for your entire range (Obviously, adjusting the 180 row reference to suit your data-set)

Basically, what you're saying is:

Give me a TRUE only if there is at least one row in my other sheet where:
 -  The IDs match
 -  [My Date] minus row's [Start date] >= 0
 -  Row's [End Date] - [My Date] >= 0

Hope that makes sense!

Upvotes: 0

ROMANIA_engineer
ROMANIA_engineer

Reputation: 56714

So, you have 3 problems:

1) Take value from another worksheet:

Dim startDate As Date
startDate = ActiveWorkbook.worksheets("OtherSheetName").cells(row,col).Value

2) Compare data:

If startDate <= actualDate And actualDate <= endDate Then
    ...
Else
    ...
End If

3) Set cell value:

ActiveWorkbook.worksheets("SheetName").cells(row,col).Value = something

Combine those steps and you'll obtain a solution for your problem.

Upvotes: 0

Related Questions