Find Number smallest and largest between a group of numbers that are in a 2d range of cells.

[anilsharaf]

My question is in the last Line of the Post. Below 2nd Table is a sitting arrangement of Examination. I have sitting in 4 rooms for 2 classes. Total Number of students and their Roll Numbers are as follows:

Class	Roll No from	Roll No To	Total Students
9A	9101	9159	59
9B	9201	9249	49
11a	11101	11120	20
11b	11201	11226	26
11c	11301	11325	25

Now This is the Sitting Table:

	0	Colm 1	Colm 2	Colm 3	Colm 4	Colm 5
	Row 5	9216	11225	9221	11304	9226
	Row 4	9215	11224	9220	11303	9225
	Row 3	9214	11223	9219	11302	9224
	Row 2	9213	11222	9218	11301	9223
Entrance	Row 1	9212	11221	9217	11226	9222
Abstract :
Class	From	To	Total
9B	9212	9226	15
11B	11221	11226	06
11C	11301	11304	04
Total			25

Please suggest me any Function or UDF or Sub to detect the Numbers that are in Abstract box. They are to be detected from the Sitting Table.
Thanks in advance.

 

[Cubist]

-

 

[kvsrinivasamurthy]

Code for macro:

Sub GetAbstract()
Dim rstrng As Range, sitrng As Range
Dim A, T&, Ta&, K&, X&, Tot&, stno&, ndno&

A = Range("A2:C6")
Set sitrng = Range("C10:G14")
Set rstrng = Range("A18")
ReDim R(1 To UBound(A, 1), 1 To 4)

For T = 1 To UBound(A, 1)
stno = 0: ndno = 0
    For Ta = A(T, 2) To A(T, 3)
    K = WorksheetFunction.CountIf(sitrng, Ta)
    If K > 0 Then
        If stno = 0 Then stno = Ta
    Else
    If stno > 0 Then ndno = Ta - 1: Exit For
    End If
    Next Ta
If stno > 0 Then
ndno = Ta - 1
X = X + 1: R(X, 1) = A(T, 1): R(X, 2) = stno: R(X, 3) = ndno: R(X, 4) = ndno - stno + 1
Tot = Tot + R(X, 4)
End If

Next T
With rstrng
.CurrentRegion.Clear
.Resize(1, 4) = Array("Class", "From", "To", "Total")
.Offset(1, 0).Resize(X, 4) = R
.Offset(X + 1, 0).Resize(1, 4) = Array("Total", "", "", Tot)
.CurrentRegion.Borders.LineStyle = xlContinuous
End With
End Sub

Range A18:D22 is macro result.

 

[anilsharaf]

Code for macro:

Sub GetAbstract()
Dim rstrng As Range, sitrng As Range
Dim A, T&, Ta&, K&, X&, Tot&, stno&, ndno&

A = Range("A2:C6")
Set sitrng = Range("C10:G14")
Set rstrng = Range("A18")
ReDim R(1 To UBound(A, 1), 1 To 4)

For T = 1 To UBound(A, 1)
stno = 0: ndno = 0
    For Ta = A(T, 2) To A(T, 3)
    K = WorksheetFunction.CountIf(sitrng, Ta)
    If K > 0 Then
        If stno = 0 Then stno = Ta
    Else
    If stno > 0 Then ndno = Ta - 1: Exit For
    End If
    Next Ta
If stno > 0 Then
ndno = Ta - 1
X = X + 1: R(X, 1) = A(T, 1): R(X, 2) = stno: R(X, 3) = ndno: R(X, 4) = ndno - stno + 1
Tot = Tot + R(X, 4)
End If

Next T
With rstrng
.CurrentRegion.Clear
.Resize(1, 4) = Array("Class", "From", "To", "Total")
.Offset(1, 0).Resize(X, 4) = R
.Offset(X + 1, 0).Resize(1, 4) = Array("Total", "", "", Tot)
.CurrentRegion.Borders.LineStyle = xlContinuous
End With
End Sub

Range A18:D22 is macro result.

View attachment 108597

Thank You very much It worked.

 

[anilsharaf]

Thank You Very much It worked. But What if I want to supply the following ranges through an Input Box:
A = Range("A2:C6")
Set sitrng = Range("C10:G14")
Set rstrng = Range("A18")
In Other room sitting ranges are different.

 

[anilsharaf]

This Worked using Input Box To Supply Ranges:
Sub GetAbstractUsingInputBox()
Dim rstrng As Range, sitrng As Range
Dim A, T&, Ta&, K&, X&, Tot&, stno&, ndno&

A = Application.InputBox( _
Title:="Select the 3 Colm GOSWARA", _
Prompt:="Select the range in which Your 3 Colm Roll No GosWara is", _
Type:=8)
Set sitrng = Application.InputBox( _
Title:="Select only Roll Nos That are in Sitting Table", _
Prompt:="Select the Roll Nos in Room Sitting", _
Type:=8)
Set rstrng = Application.InputBox( _
Title:="Select One Cell where Abstract is to be written", _
Prompt:="Select only one cell", _
Type:=8)
ReDim R(1 To UBound(A, 1), 1 To 4)

For T = 1 To UBound(A, 1)
stno = 0: ndno = 0
For Ta = A(T, 2) To A(T, 3)
K = WorksheetFunction.CountIf(sitrng, Ta)
If K > 0 Then
If stno = 0 Then stno = Ta
Else
If stno > 0 Then ndno = Ta - 1: Exit For
End If
Next Ta
If stno > 0 Then
ndno = Ta - 1
X = X + 1: R(X, 1) = A(T, 1): R(X, 2) = stno: R(X, 3) = ndno: R(X, 4) = ndno - stno + 1
Tot = Tot + R(X, 4)
End If

Next T
With rstrng
.CurrentRegion.Clear
.Resize(1, 4) = Array("Class", "From", "To", "Total")
.Offset(1, 0).Resize(X, 4) = R
.Offset(X + 1, 0).Resize(1, 4) = Array("Total", "", "", Tot)
.CurrentRegion.Borders.LineStyle = xlContinuous
End With
End Sub