group values based on time slot & week day

[rameshppc]

Hi good after noon,

i have train numbers and concerned time for all week days in my input sheet. I want to extract the data based on time slot & week day mentioned in the output sheet format.
sample workbook. I have attached sample workbook for your kind reference. kindly help me get the result.

 

[RudRud]

Kindly give a shot @rameshppc

You may double click Output 1 A1 to automatically run the code (whenever you doubleclick A1 (Output 1 sheet) the code will run)

Right click Output 1 -> View code -> Paste below code

SAMPLED WORK.xlsx
	A	B	C	D	E	F	G	H	I	J	K	L
1	FRIDAY
2	FROM	TO	FROM	TO	FROM	TO	FROM	TO	FROM	TO	FROM	TO
3	7:30	7:59	8:00	8:29	8:30	8:59	9:00	9:29	9:30	9:59	10:00	10:29
4	NUMBER	TIME	NUMBER	TIME	NUMBER	TIME	NUMBER	TIME	NUMBER	TIME	NUMBER	TIME
5	20644	7:58	22666	8:07	12680	8:32			12626	9:42	12677	10:02
6	22504	7:52	22616	8:22							22638	10:12
7			12516	8:27
8
OUTPUT 1

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
K3	Cell Value	contains "DROP DOWN"	text	NO
K3	Cell Value	contains "DROP DOWN"	text	NO

Cells with Data Validation
Cell	Allow	Criteria
A1:L1	List	=INPUT!$A$1:$N$1

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%
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

a = ws.Range(ws.Cells(f.Row, f.Column), ws.Cells(ws.UsedRange.Rows.Count, 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
                k = k + 1
            Else
                dict.Add o(1, j), 1 'If 1st time found, then put in row 1
                k = 1
            End If
            b(k, j) = a(i, 1) 'Number
            b(k, 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

 

[RudRud]

Adjust a little bit for the array of B, kindly use below code instead

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

 

[Fluff]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: group values based on time slot & week day
There is no need to repeat the link(s) provided above but if you have posted the question at other places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.