Search on date not working?



We like to search on some dates we selected from the checkbox's in a loop 

but seems it still keeps some dates out from the loop

the DB m_endtime has the date/time value

and we save our data as a date only like: day-month-year

'Got 12 checkboxs that has tag with 01 till 12 for the months
For Each Ctrl In frmStatistics.Controls
 If TypeName(Ctrl) = "CheckBox" Then 
    If Ctrl.value = True Then 'if the checkbox is checked

       GetStatistics Ctrl.Tag & "-" & "20" 'must looks like 05-20 ect... month-year

 End If
 End If
Next Ctrl
Function GetStatistics (txt as string)
    Dim ws         As Worksheet                ' as per WsName
     Dim intColIndex As Integer    
    Set DBcon = New ADODB.Connection
    Set DBrs = New ADODB.Recordset
    Set ws = Worksheets("Sheet4") ' load data into our sheet
    PathDB = PathToFile(database)
    Dim dt As Date
     constring = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathDB & ";Jet OLEDB:Database Password='" & pass & "';Mode=Share Exclusive"
    DBcon.Open (constring)
    Dim tt, tx As String

DBQuery = "SELECT * FROM TBL_ImportList " & _
    "WHERE m_endtime LIKE ""%" & Format(txt, "mm-yy") & "%""" ' here we get a part of our search not all of them 
DBrs.Open DBQuery, DBcon
For intColIndex = 0 To DBrs.Fields.Count - 1
   ws.Cells(1, intColIndex + 1).value = DBrs.Fields(intColIndex).Name ' name values in row A1
If Not DBrs.EOF Then
    ws.Range("A2").CopyFromRecordset DBrs ' Data search return into sheet4
    End If
    Set DBrs = Nothing
    Set DBcon = Nothing

End Function

Database can be found here:


Seems when found results it clears the sheet? over and over again...

Demo file has been added.




Selected Answer
  • In Private Sub CommandButton1_Click() there is a loop.
  • For Each Ctrl In Me.Controls
  • which calls GetStatistics m_id & "-" & TextBox1.Text, "admin", "Database.ACCDB"
  • which writes the data to ws.Range("A2").CopyFromRecordset DBrs

Obviously, that same range is used on every loop. Therefore you will only ever get to see the last set of data unless the last set is shorter than any of the previous. In that case you will see some data that don't belong at the bottom.

Therefore you should do two things.

  1. Clear the space of any previous data
  2. Make the destination cell dynamic, perhaps using code as shown below
    which would define the cell below the last used cell in collumn A.
    If Not DBrs.EOF Then
        ' Data search return into sheet4
        Ws.Cells(Ws.RowsCount, "A").End(xlUp).Offset(1).CopyFromRecordset DBrs
    End If
    Set DBrs = Nothing
    Set DBcon = Nothing

By the way, the following snippet of your code is inviting me to comment. If you like, please read my commentsd below it.

On Error GoTo procerr
    If Not DBrs.EOF Then
    ws.Range("A2").CopyFromRecordset DBrs
    End If
    Set DBrs = Nothing
    Set DBcon = Nothing

    GetStatistics = True

'MsgBox (Err.Number)
 Exit Function

End Function
  1. GoTo commands are considered disruptive of the flow of code. Best practice is to avoid them.
    1. An exception would be a true error handler that identifies and corrects the error and ends on Resume, which returns code execution to the point where the error occurred. An example would be a missing worksheet which the error handler creates.
  2. Your "error handler" ends on Exit Function which, to be frank, doesn't make a lot of sense coming, as it does here, just before End Function. Omitting the line would proviode the same result with less code.
  3. In order to maintain the flow of execution it's better to use On Error Resume Next just before the line you expect to cause the error and then
    If Err.Number Then         ' if Err is any number other than 0
        MsgBox Err.Number & vbCR &  Err.Description
        Exit Function
    End If
  4. Of course, Exit Function is also a disruption of the flow but it is acceptable here because this is a fishing exhibition. You just want to know the name of the error and the final version of the code won't include those 4 lines. Where this isn't the case a construction like the one shown next may be preferrable. It just continues execution after the message.
    If Not DBrs.EOF Then
        On Error Resume Next
        ws.Range("A2").CopyFromRecordset DBrs
        if Err.Number Then MsgBox "Couldn't read the recordset."
    End If


Thanks Variatus as always,
Appriciated you are helping me
but still a little confused where to add this
    ws.Cells(ws.Rows.Count, "A").End(xlUp).Offset (1)

I have placed it almost everywhere but keeps overwrite the data.
Any suggestions please
Thank you
GhostofWanted (rep: 30) Oct 28, '20 at 3:23 pm
I've added a bigger snippet in my answer above. It isn't tested but I think it should work. Please try it.
Variatus (rep: 4864) Oct 28, '20 at 9:29 pm
Hi Variatus,

Keep testing it but always same results
empty or same line.
    intColIndex = ws.Range(ws.Rows.Count, "A").End(xlUp).Offset(1)
    ws.Cells(intColIndex, 1).CopyFromRecordset DBrs

but yes your code did the job :)
thank you alot
you are the best :D

Again learned something new for in the future.
GhostofWanted (rep: 30) Oct 29, '20 at 12:22 am
Add to Discussion

Answer the Question

You must create an account to use the forum. Create an Account or Login