Create a custom range number list till max input

motilulla · Jul 1, 2023

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

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 · Jul 1, 2023

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

3

890

1249

930

4

Friction

50

Friction

75

Friction

100

5

6

1

1

1

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

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 · Jul 1, 2023

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

7

8

9

10

11

12

13

14

15

16

17

18

19

20

21

22

23

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 · Jul 2, 2023

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

VBA Code:

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 · Jul 2, 2023

Peter_SSs said:
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 · Jul 2, 2023

DanteAmor said:
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 · Jul 2, 2023

Ezguy4u said:

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

VBA Code:

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.

VBA Code:

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

Code:

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 · Jul 2, 2023

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.

VBA Code:

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 · Jul 2, 2023

Ezguy4u said:
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.

VBA Code:

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.

Ezguy4u said:
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.

Ezguy4u said:
Let's try another Dim statement.

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

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

No need you are legend!

Ezguy4u said:
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 · Jul 2, 2023

Ezguy4u said:
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.

Ezguy4u said:
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.

VBA Code:

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

Create a custom range number list till max input

motilulla

Well-known Member

Excel Facts

Peter_SSs

MrExcel MVP, Moderator

DanteAmor

Well-known Member

Ezguy4u

Active Member

motilulla

Well-known Member

motilulla

Well-known Member

motilulla

Well-known Member

Ezguy4u

Active Member

motilulla

Well-known Member

Peter_SSs

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

Create a custom range number list till max input

Well-known Member

Excel Facts

MrExcel MVP, Moderator

Well-known Member

Active Member

​

Well-known Member

Well-known Member

Well-known Member

​

Active Member

Well-known Member

MrExcel MVP, Moderator

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock