Create a custom range number list till max input

[motilulla]

Using Excel 2010
Hello,

Here below in the sheet I have shown 3 examples but need macro or formula which I want to create a custom range number list till max input….
Example1…D3 max range 890 friction 50 create range from 1 to 890 in range C6:E23

Example2…H3 max range 1249 friction 75 create range from 1 to 1249 in range G6:I22

Example2…L3 max range 930 friction 100 create range from 1 to 930 in range K6:M15

Note: I want a formula or a macro which can be used in Excel 2000 also.
Here is an example sheet with expected results…

Sort By Range.xls
	A	B	C	D	E	F	G	H	I	J	K	L	M	N
1
2				Max Range				Max Range				Max Range
3				890				1249				930
4				Friction 50				Friction 75				Friction 100
5
6			1	To	50		1	To	75		1	To	100
7			51	To	100		76	To	150		101	To	200
8			101	To	150		151	To	225		201	To	300
9			151	To	200		226	To	300		301	To	400
10			201	To	250		301	To	375		401	To	500
11			251	To	300		376	To	450		501	To	600
12			301	To	350		451	To	525		601	To	700
13			351	To	400		526	To	600		701	To	800
14			401	To	450		601	To	675		801	To	900
15			451	To	500		676	To	750		901	To	930
16			501	To	550		751	To	825
17			551	To	600		826	To	900
18			601	To	650		901	To	975
19			651	To	700		976	To	1.050
20			701	To	750		1.051	To	1.125
21			751	To	800		1.126	To	1.200
22			801	To	850		1.201	To	1.249
23			851	To	890
24
Sheet1

Regards,
Moti

 

[Peter_SSs]

Simpler if you could put that Friction number in its own cell.

Also remember that with XL2BB, no need to show irrelevant columns/rows (eg columns A:B here). Either hide them or just not include them in your selection. Keeps your mini sheet smaller.

motilulla.xlsm
	C	D	E	F	G	H	I	J	K	L	M
2		Max Range				Max Range				Max Range
3		890				1249				930
4		Friction	50			Friction	75			Friction	100
5
6	1	To	50		1	To	75		1	To	100
7	51	To	100		76	To	150		101	To	200
8	101	To	150		151	To	225		201	To	300
9	151	To	200		226	To	300		301	To	400
10	201	To	250		301	To	375		401	To	500
11	251	To	300		376	To	450		501	To	600
12	301	To	350		451	To	525		601	To	700
13	351	To	400		526	To	600		701	To	800
14	401	To	450		601	To	675		801	To	900
15	451	To	500		676	To	750		901	To	930
16	501	To	550		751	To	825
17	551	To	600		826	To	900
18	601	To	650		901	To	975
19	651	To	700		976	To	1050
20	701	To	750		1051	To	1125
21	751	To	800		1126	To	1200
22	801	To	850		1201	To	1249
23	851	To	890
24
Sheet1

Cell Formulas
Range	Formula
D6:D24,L6:L24,H6:H24	D6	=IF(C6="","","To")
E6:E24,M6:M24,I6:I24	E6	=IF(C6="","",MIN(C6+E$4-1,D$3))
C7:C24,K7:K24,G7:G24	C7	=IF(LOOKUP(9^9,C$6:C6)+E$4>D$3,"",C6+E$4)

 

[DanteAmor]

Try the next alternative.
It would be more convenient if you put the friction value in one cell and the title in another cell, see my example.

Formulas start in cell C6

Dante Amor
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2
3			Max Range	890			Max Range	1249			Max Range	930
4			Friction	50			Friction	75			Friction	100
5
6			1	To	50		1	To	75		1	To	100
7			51	To	100		76	To	150		101	To	200
8			101	To	150		151	To	225		201	To	300
9			151	To	200		226	To	300		301	To	400
10			201	To	250		301	To	375		401	To	500
11			251	To	300		376	To	450		501	To	600
12			301	To	350		451	To	525		601	To	700
13			351	To	400		526	To	600		701	To	800
14			401	To	450		601	To	675		801	To	900
15			451	To	500		676	To	750		901	To	930
16			501	To	550		751	To	825
17			551	To	600		826	To	900
18			601	To	650		901	To	975
19			651	To	700		976	To	1050
20			701	To	750		1051	To	1125
21			751	To	800		1126	To	1200
22			801	To	850		1201	To	1249
23			851	To	890
24
25
Hoja3

Cell Formulas
Range	Formula
K6:K25,G6:G25,C6:C25	C6	=IFERROR(IF(E5+1<D$3,E5+1,""),"")
L6:L25,H6:H25,D6:D25	D6	=IF(E6="","","To")
M6:M25,I6:I25,E6:E25	E6	=IF(C6="","",IF(D$4+E5<=D$3,D$4+E5,D$3))

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[Ezguy4u]

​

motilulla because you can never have too many solutions, here is another one. If you have any problems, questions or suggestions, let us know.

Sub Prog2()

Dim Count2 As Double
Dim Fric As Integer
Dim CellCnt As Integer

Count = Range("D3")
Fric = Range("E4")
CellCnt = Cells(Rows.Count, "C").End(xlUp).Row
    Range(Range("C6"), Cells(CellCnt, 5)).Select
    Selection.Delete Shift:=xlToLeft
    
    
Range("C6") = 1
Range("D6") = "To"
Range("E6") = Fric

Count2 = Range("D3") / Range("E4")

For i = 7 To (5 + Count2)

Cells(i, 3) = Cells(i - 1, 5) + 1
Cells(i, 4) = "To"
Cells(i, 5) = Fric + Cells(i - 1, 5)

Next i

If Range("D3") > Cells(i, 5) Then
    Cells(i, 3) = Cells(i - 1, 5) + 1
    Cells(i, 4) = "To"
    Cells(i, 5) = Range("D3")
End If

Columns("C:E").Select
With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
Range("C6").Select
End Sub

	Max Range
	1249
	Friction	75
1	To	75
76	To	150
151	To	225
226	To	300
301	To	375
376	To	450
451	To	525
526	To	600
601	To	675
676	To	750
751	To	825
826	To	900
901	To	975
976	To	1050
1051	To	1125
1126	To	1200
1201	To	1249

 

[motilulla]

Simpler if you could put that Friction number in its own cell.

Also remember that with XL2BB, no need to show irrelevant columns/rows (eg columns A:B here). Either hide them or just not include them in your selection. Keeps your mini sheet smaller.

motilulla.xlsm
	C	D	E	F	G	H	I	J	K	L	M
2		Max Range				Max Range				Max Range
3		890				1249				930
4		Friction	50			Friction	75			Friction	100
5
6	1	To	50		1	To	75		1	To	100
7	51	To	100		76	To	150		101	To	200
8	101	To	150		151	To	225		201	To	300
9	151	To	200		226	To	300		301	To	400
10	201	To	250		301	To	375		401	To	500
11	251	To	300		376	To	450		501	To	600
12	301	To	350		451	To	525		601	To	700
13	351	To	400		526	To	600		701	To	800
14	401	To	450		601	To	675		801	To	900
15	451	To	500		676	To	750		901	To	930
16	501	To	550		751	To	825
17	551	To	600		826	To	900
18	601	To	650		901	To	975
19	651	To	700		976	To	1050
20	701	To	750		1051	To	1125
21	751	To	800		1126	To	1200
22	801	To	850		1201	To	1249
23	851	To	890
24
Sheet1

Cell Formulas
Range	Formula
D6:D24,L6:L24,H6:H24	D6	=IF(C6="","","To")
E6:E24,M6:M24,I6:I24	E6	=IF(C6="","",MIN(C6+E$4-1,D$3))
C7:C24,K7:K24,G7:G24	C7	=IF(LOOKUP(9^9,C$6:C6)+E$4>D$3,"",C6+E$4)

Hello Peter_SSs, I want to conform that your formula worked perfect to my both versions.

I will follow-up your suggestion next time and will defiantly keep mini sheet smaller, thank you for your guidance.

Thank you for your kind help.

Nice weekend and wish you Good Luck.

Kind Regards,
Moti

 

[motilulla]

Try the next alternative.
It would be more convenient if you put the friction value in one cell and the title in another cell, see my example.

Formulas start in cell C6

Dante Amor
	A	B	C	D	E	F	G	H	I	J	K	L	M
1
2
3			Max Range	890			Max Range	1249			Max Range	930
4			Friction	50			Friction	75			Friction	100
5
6			1	To	50		1	To	75		1	To	100
7			51	To	100		76	To	150		101	To	200
8			101	To	150		151	To	225		201	To	300
9			151	To	200		226	To	300		301	To	400
10			201	To	250		301	To	375		401	To	500
11			251	To	300		376	To	450		501	To	600
12			301	To	350		451	To	525		601	To	700
13			351	To	400		526	To	600		701	To	800
14			401	To	450		601	To	675		801	To	900
15			451	To	500		676	To	750		901	To	930
16			501	To	550		751	To	825
17			551	To	600		826	To	900
18			601	To	650		901	To	975
19			651	To	700		976	To	1050
20			701	To	750		1051	To	1125
21			751	To	800		1126	To	1200
22			801	To	850		1201	To	1249
23			851	To	890
24
25
Hoja3

Cell Formulas
Range	Formula
K6:K25,G6:G25,C6:C25	C6	=IFERROR(IF(E5+1<D$3,E5+1,""),"")
L6:L25,H6:H25,D6:D25	D6	=IF(E6="","","To")
M6:M25,I6:I25,E6:E25	E6	=IF(C6="","",IF(D$4+E5<=D$3,D$4+E5,D$3))

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

Hello DanteAmor, I can say your formula worked perfectly with version 2010 but not with 2000 I guess function “=IFERROR” does not have in version 2000 may be that can be the reason.

Thank you for your kind help.

Nice weekend and wish you Good Luck.

Kind Regards,
Moti

 

[motilulla]

​

motilulla because you can never have too many solutions, here is another one. If you have any problems, questions or suggestions, let us know.

Sub Prog2()

Dim Count2 As Double
Dim Fric As Integer
Dim CellCnt As Integer

Count = Range("D3")
Fric = Range("E4")
CellCnt = Cells(Rows.Count, "C").End(xlUp).Row
    Range(Range("C6"), Cells(CellCnt, 5)).Select
    Selection.Delete Shift:=xlToLeft
 
 
Range("C6") = 1
Range("D6") = "To"
Range("E6") = Fric

Count2 = Range("D3") / Range("E4")

For i = 7 To (5 + Count2)

Cells(i, 3) = Cells(i - 1, 5) + 1
Cells(i, 4) = "To"
Cells(i, 5) = Fric + Cells(i - 1, 5)

Next i

If Range("D3") > Cells(i, 5) Then
    Cells(i, 3) = Cells(i - 1, 5) + 1
    Cells(i, 4) = "To"
    Cells(i, 5) = Range("D3")
End If

Columns("C:E").Select
With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
Range("C6").Select
End Sub

	Max Range
	1249
	Friction	75
1	To	75
76	To	150
151	To	225
226	To	300
301	To	375
376	To	450
451	To	525
526	To	600
601	To	675
676	To	750
751	To	825
826	To	900
901	To	975
976	To	1050
1051	To	1125
1126	To	1200
1201	To	1249

Hello Ezguy4u, I like your VBA solution it is more practical. I think it does not need to be included 2 following lines code can be removed.

Range(Range("C6"), Cells(CellCnt, 5)).Select
Selection.Delete Shift:=xlToLeft

Secondly it works perfect till Friction 32767, as I increase to 32768 it gives me an error “6” and code stop at line below

Fric = Range("E4")

and highlight in yellow. For example you try put max range 5.000.000 and Friction 32768 it will produce the error "6". Please can you take a look at it?

Thank you for your kind help.

Nice weekend and wish you Good Luck.

Kind Regards,
Moti

 

[Ezguy4u]

Moti the line "CellCnt = Cells(Rows.Count, "C").End(xlUp).Row" is also a part of those 2 lines of code and what they all do is delete the previous calculation. Now you could take those 3 lines out, but you would have to manually delete the previous calculation. Now I have to ask you a question, is 5.000.000 the same as 5,000,000? In other words, are you using a period instead of a comma? Even better is to use no period or commas. Just 5000000 is better. Let's try another Dim statement. Again if you have any questions, let us know. Maybe some A+ student can suggest a better Dim that Variant.

Sub Prog3()

Dim Fric As Variant
Dim CellCnt As Integer
Dim Count2 As Variant

Count = Range("D3")
Fric = Range("E4")
CellCnt = Cells(Rows.Count, "C").End(xlUp).Row
    Range(Range("C6"), Cells(CellCnt, 5)).Select
    Selection.Delete Shift:=xlToLeft
    
    
Range("C6") = 1
Range("D6") = "To"
Range("E6") = Fric

Count2 = Range("D3") / Range("E4")

For i = 7 To (5 + Count2)

Cells(i, 3) = Cells(i - 1, 5) + 1
Cells(i, 4) = "To"
Cells(i, 5) = Fric + Cells(i - 1, 5)

Next i

If Range("D3") > Cells(i, 5) Then
    Cells(i, 3) = Cells(i - 1, 5) + 1
    Cells(i, 4) = "To"
    Cells(i, 5) = Range("D3")
End If

Columns("C:E").Select
With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
Range("C6").Select
End Sub

 

[motilulla]

Moti the line "CellCnt = Cells(Rows.Count, "C").End(xlUp).Row" is also a part of those 2 lines of code and what they all do is delete the previous calculation. Now you could take those 3 lines out, but you would have to manually delete the previous calculation.

Sub Prog3()

Dim Fric As Variant
Dim CellCnt As Integer
Dim Count2 As Variant

End Sub

Hello Ezguy4u, I am sorry you are correct I did not realized these lines delete all previous calculations while every time macro is run with new friction or max range it is absolutely perfect.

Now I have to ask you a question, is 5.000.000 the same as 5,000,000? In other words, are you using a period instead of a comma? Even better is to use no period or commas. Just 5000000 is better.

I was using the period separator “5.000.000 the same as 5,000,000” as per different regions settings. But I will follow-up your suggestion.

Let's try another Dim statement.

Wow Ezguy4u, this Dim statement worked like magic 100% accurate!

Maybe some A+ student can suggest a better Dim that Variant.

No need you are legend!

Again if you have any questions, let us know.

All is worked well here are the example results….

Sort By Range.xls
	C	D	E
1
2		Max Range
3		48000000
4		Friction	13983816
5
6	1	To	13983816
7	13983817	To	27967632
8	27967633	To	41951448
9	41951449	To	48000000
10
Sheet1-1

I appreciate your sincere help. I wish you Good Luck!

Kind Regards,

Moti

 

[Peter_SSs]

what they all do is delete the previous calculation.

A little risky in my opinion as if there was no previous calculation they delete everything in that header area.
I would also recommend not using one of vba's standard words as a variable name (eg Count) as that can sometimes lead to disastrous results.

Let's try another Dim statement

Here is another option with no Dim statements at all & no looping to create each row individually.
This also deletes any previous calculation but preserves the heading section if no prior calc.

Sub CreateCustomRange()
  Range("C1", Range("E" & Rows.Count).End(xlUp)).Offset(5).Clear
  With Range("C6:E6").Resize(Range("D3").Value / Range("E4").Value + 1)
    .Formula = Array("=C5+E$4", "To", "=min(E5+E$4,D$3)")
    .Cells(1).Value = 1
    .Value = .Value
    .Columns(2).HorizontalAlignment = xlCenter
    .Font.Bold = True
    If .Cells(.Rows.Count, 1).Value > Range("D3").Value Then .Rows(.Rows.Count).Clear
  End With
End Sub

Example:

motilulla.xlsm
	C	D	E
1
2		Max Range
3		48000000
4		Friction	13983816
5
6	1	To	13983816
7	13983817	To	27967632
8	27967633	To	41951448
9	41951449	To	48000000
10
Sheet4