Expand the range value and assign it to a new array

[anilsharaf]

I have this data

Sitting Board_V1 Principle and Module InProcess.xlsm
	A	B	C	D	E	F	G	H
1	Sn_Final_according_to_Check_List	RN_from	RN_To	Medium	Type	Sort3_Center_Number_	School_Name_Hss_2024	Total_Students
2	1	2243203786	2243203830	Hindi	Regular	321042	Barpali	45
3	2	2243203831	2243203899	Hindi	Regular	321044	Boys	69
4	3	2243203946	2243203981	Hindi	Regular	321070	Madwa	36
5	4	2243203982	2243204046	Hindi	Regular	321224	Pithampur	65
6	5	2243204115	2243204139	Hindi	Regular	322292	DVM	25
7	6	2243280021	2243280021	Hindi	Div Improve	321044	Boys	01
8	7	2243299002	2243299002	Hindi	Div Improve	321070	Madwa	01
9	8	2243203900	2243203945	English	Regular	321044	Atmanand	46
10	9	2243204047	2243204114	English	Regular	322071	Lions	68
11	10	2243280022	2243280022	English	Div Improve	322071	Lions	01
12				Tot				357
AllotedRollNos

And Output data wanted first putting it in an array of NewTable (1 to 357, 1 to 7) and then to sheet named RollNos Like this

Sitting Board_V1 Principle and Module InProcess.xlsm
	A	B	C	D	E	F	G
1	Sort 3 Sn	Roll No	Medium	Type RegOrDivImprove	Center No	School Name	Nominal Sheet No
2	1	3786	Hindi	Regular	321042	Barpali	1
3	2	3787	Hindi	Regular	321043	Barpali	1
4	3	3788	Hindi	Regular	321044	Barpali	1
5	4	3789	Hindi	Regular	321045	Barpali	1
6	5	3790	Hindi	Regular	321046	Barpali	1
7	6	3791	Hindi	Regular	321047	Barpali	2
8	7	3792	Hindi	Regular	321048	Barpali	2
9	8	3793	Hindi	Regular	321049	Barpali	2
10	9	3794	Hindi	Regular	321050	Barpali	2
11	10	3795	Hindi	Regular	321051	Barpali	2
12	11	3796	Hindi	Regular	321052	Barpali	3
13	12	3797	Hindi	Regular	321053	Barpali	3
14	13	3798	Hindi	Regular	321054	Barpali	3
15	14	3799	Hindi	Regular	321055	Barpali	3
16	15	3800	Hindi	Regular	321056	Barpali	3
17	16	3801	Hindi	Regular	321057	Barpali	4
18	17	3802	Hindi	Regular	321057	Barpali	4
RollNos

Nominal Sheet No increses 1 after 5 Roll Nos. ( 1 Nominal Roll contains 5 Roll Nos)

Option Base 1
Sub CreateRollNumberArray_notReady()
    Dim RollNumbers()
    Dim Medium() As Variant
    Dim i, ir As Long
    Dim RowCounter As Long
    
    ' Define the range for Roll Numbers and Medium
    'Dim RollNumberRange() As Range
    Dim MediumRange As Range
   RollNumberRange = Worksheets("AllotedRollNos").Range("B2:C2") ' Adjust the range as needed
    Set MediumRange = Worksheets("AllotedRollNos").Range("D2") ' Medium is in D2
    
    ' Initialize the array size based on the number of Roll Numbers
    'ReDim RollNumbers(1 To RollNumberRange.Columns.Count)
    'ReDim Medium(1 To RollNumberRange.Columns.Count)
    
    ' Expand RollNumbers
    q = LBound(RollNumberRange, 2) 'column
    q2 = UBound(RollNumberRange, 2)
    
    
    '8888888888888888888
     startNum = RollNumberRange(1, 1)
        'Debug.Print startNum
        endNum = RollNumberRange(1, 1 + 1)
        'Debug.Print endNum
        
        Tot = (endNum - startNum) + 1
        
        'ir = 1
    For i = startNum To endNum
    ir = ir + 1
    '888888888888888888888
    
        ReDim Preserve RollNumbers(ir)
        RollNumbers(ir) = i
        ReDim Preserve Medium(ir)
        Medium(ir) = MediumRange.Value
        
    Next i
    
    ' Now you have the Roll Numbers and Medium in separate arrays
    ' You can access them individually or use them as needed
    
    ' Example: Print Roll Numbers and Medium
    For i = 1 To UBound(RollNumbers)
        Debug.Print "Roll Number: " & RollNumbers(i) & ", Medium: " & Medium(i)
    Next i
End Sub

There should be a better code to do this. So please do not base the code on my code. It is based on superficial knowledge. I wanted to do it myself but I failed. Thanks in Advance.

 

[JerrExcel]

Hi there,

Can you try this code:

Sub GetList()

Dim wsO As Worksheet
Dim wsD As Worksheet

'Original raw Data
Set wsO = Sheets("AllotedRollNos")
'Destination data
Set wsD = Sheets("RollNos")

wsD.Activate
'clear Destination data
wsD.Range("A2:G2000").Clear

Dim x As Long
Dim y As Long
Dim z As Long

'row count from Original data
x = 2
'row count for Destination data
y = 2
'sequential row for total_students
z = 2

Dim a As Long
'running RN No for Destination data
a = 0

Dim data_lastrow As Long
'defined last row in Original data
data_lastrow = wsO.Cells(Rows.Count, 1).End(xlUp).Row

Do Until x = data_lastrow + 1
        a = Right(wsO.Range("B" & x).Value, 4)
        'Decide how many row to repeat
        Do Until y = z + wsO.Range("H" & x).Value
            With wsD
                .Range("A" & y).Value = y - 1
                .Range("B" & y).Value = a
                .Range("C" & y).Value = wsO.Range("D" & x).Value
                .Range("D" & y).Value = wsO.Range("E" & x).Value
                .Range("E" & y).Value = wsO.Range("F" & x).Value
                .Range("F" & y).Value = wsO.Range("G" & x).Value

            End With
            y = y + 1
            a = a + 1
        Loop
    z = z + wsO.Range("H" & x).Value
    x = x + 1
Loop

wsD.Range("G2").Value = "=IF(ROW()=2,""1"",IF(MOD(ROW()-1,5)=1,R[-1]C+1,R[-1]C))"

Dim data_lastrow2 As Long
'defined last row in Destination data
data_lastrow2 = wsD.Cells(Rows.Count, 1).End(xlUp).Row

wsD.Range("G2:G" & data_lastrow2).Select
Selection.FillDown

wsD.Range("G2:G" & data_lastrow2).Value = wsD.Range("G2:G" & data_lastrow2).Value

wsO.Activate
    
x = 0
y = 0
z = 0
a = 0
data_lastrow = 0
data_lastrow2 = 0
Set wsO = Nothing
Set wsD = Nothing

MsgBox "Data RollNos generated"

End Sub

Let me know if you get any error.
Thanks!

 

[anilsharaf]

Hi there,

Can you try this code:

Sub GetList()

Dim wsO As Worksheet
Dim wsD As Worksheet

'Original raw Data
Set wsO = Sheets("AllotedRollNos")
'Destination data
Set wsD = Sheets("RollNos")

wsD.Activate
'clear Destination data
wsD.Range("A2:G2000").Clear

Dim x As Long
Dim y As Long
Dim z As Long

'row count from Original data
x = 2
'row count for Destination data
y = 2
'sequential row for total_students
z = 2

Dim a As Long
'running RN No for Destination data
a = 0

Dim data_lastrow As Long
'defined last row in Original data
data_lastrow = wsO.Cells(Rows.Count, 1).End(xlUp).Row

Do Until x = data_lastrow + 1
        a = Right(wsO.Range("B" & x).Value, 4)
        'Decide how many row to repeat
        Do Until y = z + wsO.Range("H" & x).Value
            With wsD
                .Range("A" & y).Value = y - 1
                .Range("B" & y).Value = a
                .Range("C" & y).Value = wsO.Range("D" & x).Value
                .Range("D" & y).Value = wsO.Range("E" & x).Value
                .Range("E" & y).Value = wsO.Range("F" & x).Value
                .Range("F" & y).Value = wsO.Range("G" & x).Value

            End With
            y = y + 1
            a = a + 1
        Loop
    z = z + wsO.Range("H" & x).Value
    x = x + 1
Loop

wsD.Range("G2").Value = "=IF(ROW()=2,""1"",IF(MOD(ROW()-1,5)=1,R[-1]C+1,R[-1]C))"

Dim data_lastrow2 As Long
'defined last row in Destination data
data_lastrow2 = wsD.Cells(Rows.Count, 1).End(xlUp).Row

wsD.Range("G2:G" & data_lastrow2).Select
Selection.FillDown

wsD.Range("G2:G" & data_lastrow2).Value = wsD.Range("G2:G" & data_lastrow2).Value

wsO.Activate
   
x = 0
y = 0
z = 0
a = 0
data_lastrow = 0
data_lastrow2 = 0
Set wsO = Nothing
Set wsD = Nothing

MsgBox "Data RollNos generated"

End Sub

Let me know if you get any error.
Thanks!

No Error. Code worked Fine! Thank you so much