increase cell value by 1

[justme]

What I have is a list of items which are ranked in ascending order in column C. What I want to do is to be able to easily add line items that would require a mass re-ranking of the items which come after it.

The rows are not [necessarily] in ascending order by rank.

I would like to press a button that says re-rank. Then an input box would come up and say something like what items need to be re-ranked? and then I would enter the rank of the new line item - say it is number 5. Now all the existing line items that are ranked 5 or higher will increase in value by 1. Is this possible?

There are rows with no information that will be in the worksheet, so if there is no info in column c it should remain blank.

I hope this is a little clearer than mud....

 

[SydneyGeek]

Place this code in a new module (Alt + F11, Insert > Module, paste, then Alt + Q to return to Excel)

To run, press Alt + F8 and double-click the macro name. Or, you can assign it to a button...

View > Toolbars > Forms Toolbar.
Click the commandButton icon, draw the button where you want it on the worksheet.
When the dialog pops up, double-click the macro name to assign it to the button.
When the dialog closes, change the caption on the button.

Denis

 

[sunnyland]

Hello, try this

Sub rerank()
Dim mysheet As Worksheet
'CHANGE SHEET1 TO WHATEVER name
Set mysheet = Worksheets("Sheet1")
mysheet.Activate

Dim rerank As Integer
rerank = InputBox("Please Enter FROM which ranking you wish to increase value by one")
If IsNumeric(rerank) Then
'find the last cell in c with data
lastcellinC = Range("c65536").End(xlUp).Row
'string to hold the range reference of cells with rank higher than 5
Dim myref As String
'loop through each cell in C and if rank in higher then 5
For Each ran In Range("c1:c" & lastcellinC)
If VarType(ran) <> vbEmpty And IsNumeric(ran.Value) Then
If WorksheetFunction.Rank(ran, Columns("c").Cells, 1) >= rerank Then
myref = myref & "," & ran.Address
End If
End If
Next
'remove the first comma in references
If Left(myref, 1) = "," Then
myref = Mid(myref, 2)
End If
'if ranking range exist then increase by one
If Len(myref) > 0 Then
Range(myref).Select
For Each ran In Range(myref)
ran.Value = ran + 1
Next
Else
MsgBox "No ranking higher then " & fromrank & " was found"
End If
End If


End Sub

 

[SydneyGeek]

Oops ...

Forgot the code ...

Sub ChangeRank()
    Dim intStart As Integer
    Dim c As Range
    
    intStart = CInt(InputBox("What is the start point for changing rank?"))
    For Each c In Range("C:C").SpecialCells(xlCellTypeConstants, xlNumbers)
        If c.Value >= intStart Then c.Value = c.Value + 1
    Next c
End Sub

Denis

 

[justme]

Absolutely excellent!!

Thank you both for your answers. The code is working beautifully!