VBA Sub BetweenDates

[Pinaceous]

Hi all,

I'm working with the following sub and am wondering if there is a way to extend this range to include its column?

Please help with your posted suggestions & thank you!

Sub BTWDates()

Dim x As Date
Dim sDate1 As Date
Dim sDate2 As Date
sDate1 = #10/1/2019#                
sDate2 = #9/30/2020#                

x = ActiveSheet.Range("B8:B66")

Select Case x
  Case sDate1 To sDate2
  
        MsgBox "Within Date Range"
       
            
    Application.Cursor = xlDefault  'on completion / error
       
  Case Else
        
        MsgBox "Out of Date Specified Range"
End Select

End Sub

For example, when I do this:

x = ActiveSheet.Range("B8:B66")

in lieu of:

x = ActiveSheet.Range("B8")

it pops me with an error.

Please help me to extend the range of this sub.

Thank you!
pinaceous

 

[John_w]

How about:

Sub BTWDates()

    Dim x As Variant, d As Variant
    Dim sDate1 As Date
    Dim sDate2 As Date
    sDate1 = #10/1/2019#
    sDate2 = #9/30/2020#
    
    x = ActiveSheet.Range("B8:B66")
    
    For Each d In x
        Select Case d
            Case sDate1 To sDate2
                MsgBox d & " Within Date Range"
                Application.Cursor = xlDefault  'on completion / error
            Case Else
                MsgBox d & " Out of Date Specified Range"
        End Select
    Next

End Sub

 

[Pinaceous]

Hi John_w!

Your code which extends the range

  x = ActiveSheet.Range("B8:B66")

works perfectly!

However, the code does not exclude any of the bank cells in the specified range of that column.

Where it pops the

 MsgBox d & " Out of Date Specified Range"

for each blank cell provided in that specified range.

So, it there a way to exclude the blank cells from the code, where it only runs on the cells with a date format?

Many thanks in advance!
pinaceous


<a href="https://www.mrexcel.com/forum/profile.php?do=addlist&userlist=buddy&u=84512" target="_blank"><a href="https://www.mrexcel.com/forum/members/john_w.html" target="_blank"><a href="https://www.mrexcel.com/forum/search.php?do=finduser&userid=84512&contenttype=vBForum_Post&showposts=1" target="_blank"><a href="https://www.mrexcel.com/forum/private.php?do=newpm&u=84512" target="_blank"><a href="https://www.mrexcel.com/forum/profile.php?do=addlist&userlist=buddy&u=84512" target="_blank">

How about:

Sub BTWDates()

     Dim x As Variant, d As Variant
     Dim sDate1 As Date
     Dim sDate2 As Date
     sDate1 = #10/1/2019#
     sDate2 = #9/30/2020#
     
     x = ActiveSheet.Range("B8:B66")
     
     For Each d In x
        Select Case d
             Case sDate1 To sDate2
                 MsgBox d & " Within Date Range"
                 Application.Cursor = xlDefault  'on completion / error
             Case Else
                 MsgBox d & " Out of Date Specified Range"
         End Select
     Next

 End Sub

 

[John_w]

Add an If ... End If block:

        If d <> Empty Then

        End If

around the Select ... End Select block.

 

[Pinaceous]

Add an If ... End If block:

        If d <> Empty Then

        End If

around the Select ... End Select block.

Hi John,

I have another question, in case I apply the concept in the following way, which is how do I apply the code to act on more than one sheet in your code.

For example, if I want your code to work on sheets 1, 6, 8, & 9; in lieu of "active".

This would help, if you can specify these sheets in your code.

Thank you!
pinaceous

 

[John_w]

Try this:

Sub BTWDates2()

    Dim i As Variant
    Dim cell As Range
    Dim sDate1 As Date
    Dim sDate2 As Date
    sDate1 = #10/1/2019#
    sDate2 = #9/30/2020#
    
    For Each i In Array(1, 6, 8, 9)
        For Each cell In Worksheets(i).Range("B8:B66")
            If cell.Value <> Empty Then
                Select Case cell.Value
                    Case sDate1 To sDate2
                        MsgBox cell.Value & " Within Date Range", Title:=Worksheets(i).Name & " " & cell.Address
                        Application.Cursor = xlDefault  'on completion / error
                    Case Else
                        MsgBox cell.Value & " Out of Date Specified Range", Title:=Worksheets(i).Name & " " & cell.Address
                End Select
            End If
        Next
    Next

 End Sub

 

[Pinaceous]

Thanks John_w! I love it ?