VBA filter large list of dates and times

E

ExtraCheese

New Member
Joined
Sep 18, 2020
Messages
16
Office Version
  1. 2016
Platform
  1. Windows
Good day all.
I'm looking for a way to filter a very large list of data.
The list contains dates from the last 6 months and each date contains around 45 timestamps (approx. one each half hour). The timestamps are not exactly the same each day.
The row then lists several values I need to use for graphs.

I need two timestamps per day, around 08.00 and around 14.00. Is there a way to use a macro and get the two timestamps for each day the last 6 months?
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
Assuming the dates start in cell A2. Results in cell C2 onwards

Try this:
VBA Code: 
Sub Filter_timestamps()
  Dim a As Variant, dTime As Variant
  Dim i As Long
  Dim dic As Object
  Dim time1 As Double, time2 As Double
  Dim stor1 As Double, stor2 As Double
  Dim stmp1 As Double, stmp2 As Double
  Dim nDate As Date
 
  'I need two timestamps per day, around 08.00 and around 14.00
  stmp1 = TimeValue("08:00")
  stmp2 = TimeValue("14:00")
 
  Set dic = CreateObject("Scripting.Dictionary")
 ' Initial cell
  a = Range("A2", Range("A" & Rows.Count).End(3)).Value
 
  For i = 1 To UBound(a, 1)
    dTime = a(i, 1)
    If IsDate(dTime) Then
      nDate = DateSerial(Year(dTime), Month(dTime), Day(dTime))
      time1 = TimeValue(dTime)
      time2 = TimeValue(dTime)
      If Not dic.exists(nDate) Then
        dic(nDate) = time1 & "|" & time2
      Else
        stor1 = Split(dic(nDate), "|")(0)
        stor2 = Split(dic(nDate), "|")(1)
   
        If Abs(time1 - stmp1) < Abs(stor1 - stmp1) Then
          stor1 = time1
        End If
        If Abs(time2 - stmp2) < Abs(stor2 - stmp2) Then
          stor2 = time2
        End If
        dic(nDate) = stor1 & "|" & stor2
      End If
    End If
  Next
  'Final cell
  With Range("C2")
    .Resize(10000, 3).ClearContents
    .Resize(dic.Count, 2).Value = Application.Transpose(Array(dic.keys, dic.items))
    .Offset(0, 1).Resize(dic.Count).TextToColumns .Offset(0, 1), xlDelimited, OtherChar:="|"
    .Offset(0, 1).Resize(dic.Count).NumberFormat = "hh:mm:ss AM/PM"
  End With
End Sub

----- --
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
----- --
 
Last edited:
Upvote 0
Thank you Dante for your reply.
I've experimented a bit with your code. Stuff does seem to happen, but the macro messes up the date / timestamps somehow.
Also I forgot to mention, the line with the timestamp contains data until column K, and I need all data in that line. See example below for 1 day and 1 controller (there are 9 controllers in total).

Export_20240906T0912+0200.csv
ABCDEFGHIJK
1TimestampNameBuildingControllerInstallationModuleElementName dataInstallatiecodeValueStatus
206-03-24 00:28TestMainUnderABCDE1Valid
306-03-24 01:00TestMainUnderABCDE2Valid
406-03-24 01:32TestMainUnderABCDE3Valid
506-03-24 02:04TestMainUnderABCDE4Valid
606-03-24 02:36TestMainUnderABCDE5Valid
706-03-24 03:08TestMainUnderABCDE6Valid
806-03-24 03:40TestMainUnderABCDE7Valid
906-03-24 04:12TestMainUnderABCDE8Valid
1006-03-24 04:44TestMainUnderABCDE9Valid
1106-03-24 05:16TestMainUnderABCDE10Valid
1206-03-24 05:48TestMainUnderABCDE11Valid
1306-03-24 06:20TestMainUnderABCDE12Valid
1406-03-24 06:52TestMainUnderABCDE13Valid
1506-03-24 07:24TestMainUnderABCDE14Valid
1606-03-24 07:56TestMainUnderABCDE15Valid
1706-03-24 08:28TestMainUnderABCDE16Valid
1806-03-24 09:00TestMainUnderABCDE17Valid
1906-03-24 09:32TestMainUnderABCDE18Valid
2006-03-24 10:04TestMainUnderABCDE19Valid
2106-03-24 10:36TestMainUnderABCDE20Valid
2206-03-24 11:08TestMainUnderABCDE21Valid
2306-03-24 11:40TestMainUnderABCDE22Valid
2406-03-24 12:12TestMainUnderABCDE23Valid
2506-03-24 12:44TestMainUnderABCDE24Valid
2606-03-24 13:16TestMainUnderABCDE25Valid
2706-03-24 13:48TestMainUnderABCDE26Valid
2806-03-24 14:20TestMainUnderABCDE27Valid
2906-03-24 14:52TestMainUnderABCDE28Valid
3006-03-24 15:24TestMainUnderABCDE29Valid
3106-03-24 15:56TestMainUnderABCDE30Valid
3206-03-24 16:28TestMainUnderABCDE31Valid
3306-03-24 17:00TestMainUnderABCDE32Valid
3406-03-24 17:32TestMainUnderABCDE33Valid
3506-03-24 18:04TestMainUnderABCDE34Valid
3606-03-24 18:36TestMainUnderABCDE35Valid
3706-03-24 19:08TestMainUnderABCDE36Valid
3806-03-24 19:40TestMainUnderABCDE37Valid
3906-03-24 20:12TestMainUnderABCDE38Valid
4006-03-24 20:44TestMainUnderABCDE39Valid
4106-03-24 21:16TestMainUnderABCDE40Valid
4206-03-24 21:48TestMainUnderABCDE41Valid
4306-03-24 22:20TestMainUnderABCDE42Valid
4406-03-24 22:52TestMainUnderABCDE43Valid
4506-03-24 23:24TestMainUnderABCDE44Valid
4606-03-24 23:56TestMainUnderABCDE45Valid
Export_20240906T0912+0200
 
Upvote 0
Hi @ExtraCheese:
It is important to complete all the relevant information in your request.

You need to define the following:
1. Your request: By using "around 08.00 and around 14.00", I assume you mean the time closest to 8:00 and the time closest to 14:00, but you don't specify whether it can be before 8 or after 8, so example of 7:59 and 8:20, what is the register you need?

2. In addition to providing a sample of one day (you do not need to put 45 records, a sample of 10 records containing the hours around 8 and 14 is enough), it would be ideal if you put the expected result.

3. Now you added this comment: "there are 9 controllers in total", I don't know what you mean, and to avoid assuming what you mean, better give an example with 3 "controller" and 2 different days; and of course, put the expected result.


However, with the request you made that the result must contain up to column K, I provide you with the updated macro. The output will be in cell M2 onwards. According to your example, the output should be as follows:

varios 06sep2024.xlsm
MNOPQRSTUVW
1TimestampNameBuildingControllerInstallationModuleElementName dataInstallatiecodeValueStatus
206/03/2024 07:56:00TestMainUnderABCDE15Valid
306/03/2024 13:48:00TestMainUnderABCDE26Valid
Time


Try:
VBA Code: 
Sub Filter_timestamps()
  Dim a As Variant, b As Variant, dTime As Variant, ky As Variant
  Dim i&, j&, k&, x&, y&, nRow1&, nRow2&, nRowy&
  Dim dic As Object
  Dim time1 As Double, time2 As Double
  Dim stor1 As Double, stor2 As Double
  Dim stmp1 As Double, stmp2 As Double
  Dim nDate As Date
 
  'timestamps per day, around 08.00 and around 14.00
  stmp1 = TimeValue("08:00")
  stmp2 = TimeValue("14:00")
  'Initial cell
  a = Range("A1:K" & Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 2 To UBound(a, 1)
    dTime = a(i, 1)
    If IsDate(dTime) Then
      nDate = DateSerial(Year(dTime), Month(dTime), Day(dTime))
      time1 = TimeValue(dTime)
      time2 = TimeValue(dTime)
      If Not dic.exists(nDate) Then
        nRow1 = i
        nRow2 = i
        y = y + 1
        dic(nDate) = y & "|" & nRow1 & "|" & nRow2 & "|" & time1 & "|" & time2
      Else
        
        nRowy = Split(dic(nDate), "|")(0)
        nRow1 = Split(dic(nDate), "|")(1)
        nRow2 = Split(dic(nDate), "|")(2)
        stor1 = Split(dic(nDate), "|")(3)
        stor2 = Split(dic(nDate), "|")(4)
   
        If Abs(time1 - stmp1) < Abs(stor1 - stmp1) Then
          stor1 = time1
          nRow1 = i
        End If
        If Abs(time2 - stmp2) < Abs(stor2 - stmp2) Then
          stor2 = time2
          nRow2 = i
        End If
        dic(nDate) = nRowy & "|" & nRow1 & "|" & nRow2 & "|" & stor1 & "|" & stor2
      End If
    End If
  Next
  
  For Each ky In dic.keys
    nRowy = Split(dic(ky), "|")(0)
    nRow1 = Split(dic(ky), "|")(1)
    nRow2 = Split(dic(ky), "|")(2)
    
    k = k + 1
    For j = 1 To UBound(a, 2)
      b(k, j) = a(nRow1, j)
      b(k + 1, j) = a(nRow2, j)
    Next
    k = k + 1
  Next
  
  'Final cell
  Range("M2").Resize(k, UBound(b, 2)).Value = b
End Sub

----- --
I hope to hear from you soon.
Respectfully
Dante Amor
----- --
 
Upvote 1
Hello @DanteAmor. Thank you very much for the code, which is working very fine!

To make some things clear:
1: the code runs just fine with getting the requested timestamps.
2: Acknowledged, will do for next time!
3: 9 controller means I will have 9 different lists of 14.000 entries. I thought that would perhaps be of importance. It is irrelevant as I see now.

So once again, the code works very good for my initial request. However, I made a small mistake and need 4 timestamps each day. I have adjusted your code, but seem to be missing a step. It still returns 2 timestamps each day. Can you indicate what I'm missing here?

VBA Code: 
Private Sub CommandButton1_Click()
  Dim a As Variant, b As Variant, dTime As Variant, ky As Variant
  Dim i&, j&, k&, x&, y&, nRow1&, nRow2&, nRow3&, nRow4, nRowy&
  Dim dic As Object
  Dim time1 As Double, time2 As Double, time3 As Double, time4 As Double
  Dim stor1 As Double, stor2 As Double, stor3 As Double, stor4 As Double
  Dim stmp1 As Double, stmp2 As Double, stmp3 As Double, stmp4 As Double
  Dim nDate As Date
 
  'timestamps per day, around 00.00, 06.00, 12.00 and around 18.00
  stmp1 = TimeValue("00:00")
  stmp2 = TimeValue("06:00")
  stmp3 = TimeValue("12:00")
  stmp4 = TimeValue("18:00")
  'Initial cell
  a = Range("A1:K" & Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 2 To UBound(a, 1)
    dTime = a(i, 1)
    If IsDate(dTime) Then
      nDate = DateSerial(Year(dTime), Month(dTime), Day(dTime))
      time1 = TimeValue(dTime)
      time2 = TimeValue(dTime)
      time3 = TimeValue(dTime)
      time4 = TimeValue(dTime)
      If Not dic.exists(nDate) Then
        nRow1 = i
        nRow2 = i
        nRow3 = i
        nRow4 = i
        y = y + 1
        dic(nDate) = y & "|" & nRow1 & "|" & nRow2 & "|" & nRow3 & "|" & nRow4 & "|" & time1 & "|" & time2 & "|" & time3 & "|" & time4
      Else
        
        nRowy = Split(dic(nDate), "|")(0)
        nRow1 = Split(dic(nDate), "|")(1)
        nRow2 = Split(dic(nDate), "|")(2)
        nRow3 = Split(dic(nDate), "|")(3)
        nRow4 = Split(dic(nDate), "|")(4)
        stor1 = Split(dic(nDate), "|")(5)
        stor2 = Split(dic(nDate), "|")(6)
        stor3 = Split(dic(nDate), "|")(7)
        stor4 = Split(dic(nDate), "|")(8)
  
        If Abs(time1 - stmp1) < Abs(stor1 - stmp1) Then
          stor1 = time1
          nRow1 = i
        End If
        If Abs(time2 - stmp2) < Abs(stor2 - stmp2) Then
          stor2 = time2
          nRow2 = i
        End If
        If Abs(time3 - stmp3) < Abs(stor3 - stmp3) Then
          stor3 = time3
          nRow3 = i
        End If
        If Abs(time4 - stmp4) < Abs(stor4 - stmp4) Then
          stor4 = time4
          nRow4 = i
        End If
        dic(nDate) = nRowy & "|" & nRow1 & "|" & nRow2 & "|" & nRow3 & "|" & nRow4 & "|" & stor1 & "|" & stor2 & "|" & stor3 & "|" & stor4
      End If
    End If
  Next
 
  For Each ky In dic.keys
    nRowy = Split(dic(ky), "|")(0)
    nRow1 = Split(dic(ky), "|")(1)
    nRow2 = Split(dic(ky), "|")(2)
    nRow3 = Split(dic(ky), "|")(3)
    nRow4 = Split(dic(ky), "|")(4)
    
    k = k + 1
    For j = 1 To UBound(a, 2)
      b(k, j) = a(nRow1, j)
      b(k + 1, j) = a(nRow2, j)
      b(k + 1, j) = a(nRow3, j)
      b(k + 1, j) = a(nRow4, j)
    Next
    k = k + 1
  Next
 
  'Final cell
  Range("M2").Resize(k, UBound(b, 2)).Value = b
End Sub
 
Upvote 0
ExtraCheese said:
need 4 timestamps each day
Click to expand...
You almost did it, you just needed to increase the number of lines at the exit, currently there are 2 so you need 4 lines for each day.


Rich (BB code): 
Private Sub CommandButton1_Click()
  Dim a As Variant, b As Variant, dTime As Variant, ky As Variant
  Dim i&, j&, k&, x&, y&, nRow1&, nRow2&, nRow3&, nRow4, nRowy&
  Dim dic As Object
  Dim time1 As Double, time2 As Double, time3 As Double, time4 As Double
  Dim stor1 As Double, stor2 As Double, stor3 As Double, stor4 As Double
  Dim stmp1 As Double, stmp2 As Double, stmp3 As Double, stmp4 As Double
  Dim nDate As Date
 
  'timestamps per day, around 00.00, 06.00, 12.00 and around 18.00
  stmp1 = TimeValue("00:00")
  stmp2 = TimeValue("06:00")
  stmp3 = TimeValue("12:00")
  stmp4 = TimeValue("18:00")
  'Initial cell
  a = Range("A1:K" & Range("A" & Rows.Count).End(3).Row).Value
  ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
 
  Set dic = CreateObject("Scripting.Dictionary")
  For i = 2 To UBound(a, 1)
    dTime = a(i, 1)
    If IsDate(dTime) Then
      nDate = DateSerial(Year(dTime), Month(dTime), Day(dTime))
      time1 = TimeValue(dTime)
      time2 = TimeValue(dTime)
      time3 = TimeValue(dTime)
      time4 = TimeValue(dTime)
      If Not dic.exists(nDate) Then
        nRow1 = i
        nRow2 = i
        nRow3 = i
        nRow4 = i
        y = y + 1
        dic(nDate) = y & "|" & nRow1 & "|" & nRow2 & "|" & nRow3 & "|" & nRow4 & "|" & _
                               time1 & "|" & time2 & "|" & time3 & "|" & time4
      Else
        
        nRowy = Split(dic(nDate), "|")(0)
        nRow1 = Split(dic(nDate), "|")(1)
        nRow2 = Split(dic(nDate), "|")(2)
        nRow3 = Split(dic(nDate), "|")(3)
        nRow4 = Split(dic(nDate), "|")(4)
        stor1 = Split(dic(nDate), "|")(5)
        stor2 = Split(dic(nDate), "|")(6)
        stor3 = Split(dic(nDate), "|")(7)
        stor4 = Split(dic(nDate), "|")(8)
  
        If Abs(time1 - stmp1) < Abs(stor1 - stmp1) Then
          stor1 = time1
          nRow1 = i
        End If
        If Abs(time2 - stmp2) < Abs(stor2 - stmp2) Then
          stor2 = time2
          nRow2 = i
        End If
        If Abs(time3 - stmp3) < Abs(stor3 - stmp3) Then
          stor3 = time3
          nRow3 = i
        End If
        If Abs(time4 - stmp4) < Abs(stor4 - stmp4) Then
          stor4 = time4
          nRow4 = i
        End If
        dic(nDate) = nRowy & "|" & nRow1 & "|" & nRow2 & "|" & nRow3 & "|" & nRow4 & "|" & stor1 & "|" & stor2 & "|" & stor3 & "|" & stor4
      End If
    End If
  Next
 
  For Each ky In dic.keys
    nRowy = Split(dic(ky), "|")(0)
    nRow1 = Split(dic(ky), "|")(1)
    nRow2 = Split(dic(ky), "|")(2)
    nRow3 = Split(dic(ky), "|")(3)
    nRow4 = Split(dic(ky), "|")(4)
    
    k = k + 1
    For j = 1 To UBound(a, 2)
      b(k, j) = a(nRow1, j)
      b(k + 1, j) = a(nRow2, j)
      b(k + 2, j) = a(nRow3, j)
      b(k + 3, j) = a(nRow4, j)
    Next
    k = k + 3
  Next
 
  'Final cell
  Range("M2").Resize(k, UBound(b, 2)).Value = b
End Sub

😇
 
Upvote 1
Solution
You must log in or register to reply here.

Similar threads

D
  • Locked
  • Question
VBA to copy only matching data from 2 csv workbooks into the "Master Workbook"
Replies
1
Views
258
RoryA
RoryA
D
  • Solved
VBA to copy only matching data from 2 csv workbooks into the "MasterCSV"
2
Replies
18
Views
762
Peter_SSs
Peter_SSs
G
  • Question
'Storing' and summing data before it is overwritten.
Replies
1
Views
163
gwoolley0302
G
J
  • Solved
Filter date time data so I only get one data point per hour
2 3
Replies
24
Views
1K
Peter_SSs
Peter_SSs
B
  • Question
Income tracker ideas
Replies
1
Views
282
awoohaw
awoohaw

Forum statistics

Threads
1,221,418
Messages
6,159,791
Members
451,589
Latest member
Harold14

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