Option Compare Text
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim a(), b(), o()
Dim f As Range
Dim i%, k%, j%, lrow%
Dim chec As Byte
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.Comparemode = vbTextCompare
Set ws = Sheets("Input")
Set ws2 = Sheets("Output 1")
ReDim b(1 To 5000, 1 To 12) 'reserve row 5000 , column 12 bcos A to L From to
If Target.Row = 1 Then
Set f = ws.Range("a1:r1").Find(ws2.[a1].Value, LookIn:=xlValues)
ws2.[a5:l5000].ClearContents 'clear output1 range a5 : l5000
lrow = ws.Cells(Rows.Count, f.Column).End(xlUp).Row
a = ws.Range(ws.Cells(f.Row, f.Column), ws.Cells(lrow, f.Column + 1)).Value2
o = ws2.Range("a3:l3").Value
For i = 3 To UBound(a, 1)
For j = 1 To UBound(o, 2) Step 2 'Loop through From To Time
If a(i, 2) >= o(1, j) And a(i, 2) < o(1, j + 1) Then 'Check If Value >= From and lower to ) A3:L3
If dict.exists(o(1, j)) Then 'If already exist, then add one row below for array
dict(o(1, j)) = dict(o(1, j)) + 1
Else
dict.Add o(1, j), 1 'If 1st time found, then put in row 1
End If
b(dict(o(1, j)), j) = a(i, 1) 'Number
b(dict(o(1, j)), j + 1) = Format(a(i, 2), "Short time") 'Time
chec = 1 'If already found then skip from & time loop
If chec = 1 Then Exit For
End If
Next j
Next i
ws2.[a5].Resize(UBound(b, 1), UBound(b, 2)).Value = b
End If
End Sub