Excel 2016 - VBA - Date search allowing 2 digit and 4 digit year it searches for.

C

CrashOD

Board Regular
Joined
Feb 5, 2019
Messages
118
Office Version
  1. 2021
  2. 2016
Platform
  1. Windows
Excel 2016 - VBA - Date search allowing 2 digit and 4 digit year it searches for. right now if i enter 3/1/2022 or 3/1/22 still only searches 3/1/2022.
Private Sub btnGenerate_Click()

'On Error GoTo ErrorHandler

lblMessage.BackColor = ColorConstants.vbGreen
lblMessage.Caption = "Now, generating the report !!!"

Dim strFromDate As String
Dim strToDate As String

Dim aFromDate As Variant
Dim aToDate As Variant

Dim dtFromDate As Date
Dim dtToDate As Date
Dim dtCheckDate As Date

Dim sRLFilePath As String
Dim sCLFilePath As String

'Dim dRLMaxRows As Double
'Dim dCLMaxRows As Double

Dim strSearchDate As String

Dim oReportWorkbook As Workbook
Dim oReportWorksheet As Worksheet

Dim oWorkbook1 As Workbook
Dim oWorkbook2 As Workbook

Dim iReportRowIndex1 As Double
Dim iReportRowIndex2 As Double

strFromDate = txtFromDate.Value
strToDate = txtToDate.Value

aFromDate = Split(strFromDate, "/")
aToDate = Split(strToDate, "/")

dtFromDate = DateSerial(aFromDate(2), aFromDate(0), aFromDate(1))
dtToDate = DateSerial(aToDate(2), aToDate(0), aToDate(1))
dtCheckDate = dtFromDate

sRLFilePath = txtRLFilePath.Value
sCLFilePath = txtCLFilePath.Value

Application.Interactive = False

Set oReportWorkbook = ActiveWorkbook
Set oReportWorksheet = ActiveSheet

'Set oWorkbook1 = Workbooks.Open("D:\Country&LocalReport\2022 - ECT - Real Estate.xlsx")
'Set oWorkbook2 = Workbooks.Open("D:\Country&LocalReport\2022 - ECT - C&L - Personal.xlsm")
'Set oWorkbook1 = Workbooks.Open("D:\Country&LocalReport\RLE_County Local 2022.xls")
'Set oWorkbook2 = Workbooks.Open("D:\Country&LocalReport\Occ County Local 2022.xls")

Set oWorkbook1 = Workbooks.Open(sRLFilePath)
Set oWorkbook2 = Workbooks.Open(sCLFilePath)

'**************were on recipt leger it starts

iReportRowIndex1 = 4
iReportRowIndex2 = 4

'dRLMaxRows = CDbl(txtRLMaxRows.Value)
'dCLMaxRows = CDbl(txtCLMaxRows.Value)

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.Interactive = False
End With


Do While dtCheckDate <= dtToDate

strSearchDate = Month(dtCheckDate) & "/" & Day(dtCheckDate) & "/" & Year(dtCheckDate)
iReportRowIndex1 = ProcessReportData("RL", strSearchDate, oWorkbook1, oReportWorkbook, iReportRowIndex1)
iReportRowIndex2 = ProcessReportData("CL", strSearchDate, oWorkbook2, oReportWorkbook, iReportRowIndex2)
'iReportRowIndex1 = ProcessReportData("RL", strSearchDate, oWorkbook1, oReportWorkbook, iReportRowIndex1, dRLMaxRows)
'iReportRowIndex2 = ProcessReportData("CL", strSearchDate, oWorkbook2, oReportWorkbook, iReportRowIndex2, dCLMaxRows)
'Call ProcessReportData2(strSearchDate, oWorkbook2)
dtCheckDate = DateAdd("d", 1, dtCheckDate)

Loop

With Application
CalcMode = .Calculation
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.Interactive = True
End With

Call oWorkbook1.Close(False)
Call oWorkbook2.Close(False)

Call oReportWorksheet.Activate

lblMessage.BackColor = ColorConstants.vbGreen
lblMessage.Caption = "Completed with report generation !!!"

'Me.ActiveControl
'Unload Me

Exit Sub

ErrorHandler:

MsgBox "(GenerateReport) Something went wrong '" & Error() & "' at line " & Erl() & ", halting process!!!"
'Me.ActiveControl
lblMessage.BackColor = ColorConstants.vbGreen
lblMessage.Caption = "(GenerateReport) Something went wrong '" & Error() & "' at line " & Erl() & ", halting process!!!"

With Application
CalcMode = .Calculation
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.Interactive = True
End With

If Not oWorkbook1 Is Nothing Then Call oWorkbook1.Close(False)
If Not oWorkbook2 Is Nothing Then Call oWorkbook2.Close(False)

Call oReportWorksheet.Activate

'Unload Me

Exit Sub

End Sub
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Sort by date Sort by votes
Hi CrashOD,

what if you convert the Dates to Longs or Doubles instead of Dates?

In the future please wrap your procedures in code-tags - thanks in advance for better readability and easier copying from all those who will copy them.

Ciao,
Holger
 
Upvote 0
HaHoBe said:
Hi CrashOD,

what if you convert the Dates to Longs or Doubles instead of Dates?

In the future please wrap your procedures in code-tags - thanks in advance for better readability and easier copying from all those who will copy them.

Ciao,
Holger
Click to expand...
what do you mean in code tags? and how do you do that?
 
Upvote 0
Dim dtFromDate As Long
Dim dtToDate As Long
Dim dtCheckDate As Long

Dim dtFromDate As Double
Dim dtToDate As Double
Dim dtCheckDate As Double

unfortunately did not work. still brought only the 2022 in nothing for 22. Thanks for trying.
 
Upvote 0
Hi CrashOD,

concerning the code-tags see How to Post Your VBA Code

And concerning the 'Dates': they come from Textboxes meaning that they are strings, and these would need to be transformed into the according format by using CLng or CDbl like

VBA Code: 
Sub JustASample()
Dim strDate As String

strDate = Format(Date, "mm/dd/yy")
'output in immediate window
Debug.Print strDate                     'the string as formatted
Debug.Print CDbl(strDate)               'returning the correct number of days since 1900
Debug.Print CLng(DateValue(strDate))    'returning the number of days since 1900
Debug.Print CLng(Date)                  'same as above
End Sub

Holger
 
Upvote 0
VBA Code: 
Private Sub Label1_Click()

End Sub

Private Sub Label2_Click()

End Sub

Private Sub TextBox2_Change()

End Sub

Private Sub btnCancel_Click()
    Unload Me
End Sub

Private Sub btnGenerate_Click()
    
    'On Error GoTo ErrorHandler
    
    lblMessage.BackColor = ColorConstants.vbGreen
    lblMessage.Caption = "Now, generating the report !!!"
    
    Dim strFromDate As String
    Dim strToDate As String
    
    Dim aFromDate As Variant
    Dim aToDate As Variant
    
    Dim dtFromDate As Date
    Dim dtToDate As Date
    Dim dtCheckDate As Date
    
    Dim sRLFilePath As String
    Dim sCLFilePath As String
    
    'Dim dRLMaxRows As Double
    'Dim dCLMaxRows As Double
        
    Dim strSearchDate As String
    
    Dim oReportWorkbook As Workbook
    Dim oReportWorksheet As Worksheet

    Dim oWorkbook1 As Workbook
    Dim oWorkbook2 As Workbook
            
    Dim iReportRowIndex1 As Double
    Dim iReportRowIndex2 As Double
            
    strFromDate = txtFromDate.Value
    strToDate = txtToDate.Value
    
    aFromDate = Split(strFromDate, "/")
    aToDate = Split(strToDate, "/")
    
    dtFromDate = DateSerial(aFromDate(2), aFromDate(0), aFromDate(1))
    dtToDate = DateSerial(aToDate(2), aToDate(0), aToDate(1))
    dtCheckDate = dtFromDate
    
    sRLFilePath = txtRLFilePath.Value
    sCLFilePath = txtCLFilePath.Value
    
    Application.Interactive = False
    
    Set oReportWorkbook = ActiveWorkbook
    Set oReportWorksheet = ActiveSheet
    
    'Set oWorkbook1 = Workbooks.Open("D:\Country&LocalReport\2022 - ECT - Real Estate.xlsx")
    'Set oWorkbook2 = Workbooks.Open("D:\Country&LocalReport\2022 - ECT - C&L - Personal.xlsm")
    'Set oWorkbook1 = Workbooks.Open("D:\Country&LocalReport\RLE_County Local 2022.xls")
    'Set oWorkbook2 = Workbooks.Open("D:\Country&LocalReport\Occ County Local 2022.xls")
    
    Set oWorkbook1 = Workbooks.Open(sRLFilePath)
    Set oWorkbook2 = Workbooks.Open(sCLFilePath)
    
'**************were on recipt leger it starts
    
    iReportRowIndex1 = 4
    iReportRowIndex2 = 4
        
    'dRLMaxRows = CDbl(txtRLMaxRows.Value)
    'dCLMaxRows = CDbl(txtCLMaxRows.Value)
        
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
        .Interactive = False
    End With
        

    Do While dtCheckDate <= dtToDate
    
        strSearchDate = Month(dtCheckDate) & "/" & Day(dtCheckDate) & "/" & Year(dtCheckDate)
        iReportRowIndex1 = ProcessReportData("RL", strSearchDate, oWorkbook1, oReportWorkbook, iReportRowIndex1)
        iReportRowIndex2 = ProcessReportData("CL", strSearchDate, oWorkbook2, oReportWorkbook, iReportRowIndex2)
        'iReportRowIndex1 = ProcessReportData("RL", strSearchDate, oWorkbook1, oReportWorkbook, iReportRowIndex1, dRLMaxRows)
        'iReportRowIndex2 = ProcessReportData("CL", strSearchDate, oWorkbook2, oReportWorkbook, iReportRowIndex2, dCLMaxRows)
        'Call ProcessReportData2(strSearchDate, oWorkbook2)
        dtCheckDate = DateAdd("d", 1, dtCheckDate)
        
    Loop
        
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .Interactive = True
    End With
    
    Call oWorkbook1.Close(False)
    Call oWorkbook2.Close(False)
       
    Call oReportWorksheet.Activate
    
    lblMessage.BackColor = ColorConstants.vbGreen
    lblMessage.Caption = "Completed with report generation !!!"
    
    'Me.ActiveControl
    'Unload Me
    
    Exit Sub
    
ErrorHandler:
    
    MsgBox "(GenerateReport) Something went wrong '" & Error() & "' at line " & Erl() & ", halting process!!!"
    'Me.ActiveControl
    lblMessage.BackColor = ColorConstants.vbGreen
    lblMessage.Caption = "(GenerateReport) Something went wrong '" & Error() & "' at line " & Erl() & ", halting process!!!"
    
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .EnableEvents = True
        .Interactive = True
    End With
    
    If Not oWorkbook1 Is Nothing Then Call oWorkbook1.Close(False)
    If Not oWorkbook2 Is Nothing Then Call oWorkbook2.Close(False)
    
    Call oReportWorksheet.Activate
    
    'Unload Me
    
    Exit Sub
     
End Sub

Private Sub txtFromDate_Enter()
    txtFromDate.Value = Trim(txtFromDate.Value)
    If txtFromDate.Value <> "" Then
        lblMessage.BackColor = ColorConstants.vbGreen
        lblMessage.Caption = "You entered 'From Date' " & txtFromDate.Value & "."
    Else
        lblMessage.BackColor = ColorConstants.vbRed
        lblMessage.Caption = "Please enter 'From Date' to generate the Report!"
    End If
End Sub

Private Sub txtFromDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    lblMessage.BackColor = ColorConstants.vbGreen
    lblMessage.Caption = ""
End Sub

Private Sub txtToDate_Enter()
    txtToDate.Value = Trim(txtToDate.Value)
    If txtToDate.Value <> "" Then
        lblMessage.BackColor = ColorConstants.vbGreen
        lblMessage.Caption = "You entered 'To Date' " & txtToDate.Value & "."
    Else
        lblMessage.BackColor = ColorConstants.vbRed
        lblMessage.Caption = "Please enter 'To Date' to generate the Report!"
    End If
End Sub


Private Sub txtToDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    lblMessage.BackColor = ColorConstants.vbGreen
    lblMessage.Caption = ""
End Sub

Private Sub txtRLFilePath_Enter()
    txtRLFilePath.Value = Trim(txtRLFilePath.Value)
    If txtRLFilePath.Value <> "" Then
        lblMessage.BackColor = ColorConstants.vbGreen
        lblMessage.Caption = "You entered 'Real Estate File Path' " & txtRLFilePath.Value & "."
    Else
        lblMessage.BackColor = ColorConstants.vbRed
        lblMessage.Caption = "Please enter 'Real Estate File Path' to generate the Report!"
    End If
End Sub


Private Sub txtRLFilePath_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    lblMessage.BackColor = ColorConstants.vbGreen
    lblMessage.Caption = ""
End Sub

Private Sub txtCLFilePath_Enter()
    txtCLFilePath.Value = Trim(txtCLFilePath.Value)
    If txtRLFilePath.Value <> "" Then
        lblMessage.BackColor = ColorConstants.vbGreen
        lblMessage.Caption = "You entered 'C&L - Personal File Path' " & txtCLFilePath.Value & "."
    Else
        lblMessage.BackColor = ColorConstants.vbRed
        lblMessage.Caption = "Please enter 'C&L - Personal File Path' to generate the Report!"
    End If
End Sub


Private Sub txtCLFilePath_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    lblMessage.BackColor = ColorConstants.vbGreen
    lblMessage.Caption = ""
End Sub

Private Sub UserForm_Click()

End Sub

wow thanks. lol i was looking in excel every were for the VBA button. here is all the coding maybe that will help. this from the FOrms before it uses the data in the macro to past info. thanks so much!
 
Upvote 0
Hi CrashOD,

I would check in the exit of the textboxes if the dates fit my expectations or send the user back to the textbox like

VBA Code: 
Private Sub txtFromDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    With txtFromDate
      If Len(.Value) < 10 Or Not IsDate(.Value) Then
        MsgBox "Please enter date in format 'mm.dd.yyyy', for today like " & Format(Date, "mm/dd/yyyy"), , "Date not entered correctly"
        .SetFocus
        Cancel = True
        Exit Sub
      End If
    End With
    lblMessage.BackColor = ColorConstants.vbGreen
    lblMessage.Caption = ""
End Sub

Private Sub txtToDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    With txtToDate
      If Len(.Value) < 10 Or Not IsDate(.Value) Then
        MsgBox "Please enter date in format 'mm.dd.yyyy', for today like " & Format(Date, "mm/dd/yyyy"), , "Date not entered correctly"
        .SetFocus
        Cancel = True
        Exit Sub
      End If
    End With
    lblMessage.BackColor = ColorConstants.vbGreen
    lblMessage.Caption = ""
End Sub

I have no clue how the dates you will look for are formatted.

Holger
 
Upvote 0
in the text boxes two of them to and from the dates will be 03/01/2022 or 3/1/2022 and the same for 2 digit year. and the workbooks it searches they are formatted the same way. it picks up all the different variations if 4 digit year in the books it searches, but say i put for the search option 3/1/22 still only looks for 3/1/2022
 
Upvote 0
Hi CrashOD,

you convert the date to a string and pass that to a procedure - maybe you need to add another call with the year in that just having 2 digits.

Holger
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
Excel 2016 & 2021 VBA trying to open workbook based on Sheet 7 cell D3
Replies
2
Views
566
CrashOD
C

Forum statistics

Threads
1,224,822
Messages
6,181,165
Members
453,021
Latest member
Justyna P

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