Adj Macro to hold more pop up box Hi, I had obtained this macro, but the problem

Question

Adj Macro to hold more pop up box

Hi,

I had obtained this macro, but the problem is how could it adjusted so that it can hold more that one pop up box. The macro is meant to search within a whole column starting from a specific row, and then it searches any dates that falls within today's date - 1 and if it matches a pop up box appears and there will be a msg within.

In short I am using this macro as a means of a reminder, but how could this be adjusted so that if more than one reminder falls within that date a pop up box appears with more details.

the macro is:

Private Sub Workbook_Open()

Sheets("Bank book 1").Activate
Dim dt As Date
dt = DateSerial(Year(Now()), Month(Now()), Day(Now()))
Set rng = Range("au3:au365").Find(What:=dt + 1, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If rng Is Nothing Then
' do nothing
Else
If rng.Cells.Offset(0, -4) <> "" Then MsgBox "Tomorrow " & rng.Offset(0, -4).Value
End If
End Sub

Thanks

Explanation / Answer

..Hi,

Sheets("Bank book 1").Activate
   Dim dt As Date, Rng As Range
   Dim strFirstAddress As String
   Dim var() As Variant
   Dim intCount As Integer, strMsg As String
  
   Erase var
  
   dt = DateSerial(Year(Now()), Month(Now()), Day(Now()))
   Set Rng = Range("au3:au365").Find(What:=dt + 1, LookIn:=xlValues, _
   LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
   MatchCase:=False, SearchFormat:=False)
  
   If Not Rng Is Nothing Then
      strFirstAddress = Rng.Address
      ReDim Preserve var(1 To 1)
      var(1) = Rng.Offset(0, -4)
   End If
  
   If Not Rng Is Nothing Then
      Do
         Set Rng = Range("au3:au365").Find(After:=Rng, What:=dt + 1, LookIn:=xlValues, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
            If Rng.Address = strFirstAddress Then Exit Do
            ReDim Preserve var(1 To UBound(var) + 1)
            var(UBound(var)) = Rng.Offset(0, -4)
      Loop
   End If
  
   If Not Rng Is Nothing Then
      For intCount = 1 To UBound(var)
         If var(intCount) <> "" Then
            If Len(strMsg) = 0 Then
               strMsg = var(intCount)
            Else
               strMsg = strMsg & vbCr & var(intCount)
            End If
         End If
      Next intCount
     
      If Len(strMsg) > 0 Then MsgBox Prompt:="Tomorrow:" & vbCr & strMsg
   End If

=====^*^=====

Related Questions

Navigate

• Browse (All)
• Browse A
• Subjects

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.