Create range in where cells are not equal to zero

Question

I have a range of cells A1-A5 with random numbers. Some of the numbers are zero (no particular order). I want to create a new range in VBA that excludes each cell that equals zero. Ultimately this range or list of cells will be entered into solver VBA for the list of cells that will be changed (i.e. ByChange:="$M$3,$N$3,$O$3,$P$3,$Q$3,$R$3,$S$3,$T$3,$U$3,$V$3,$W$3,$X$3,$Y$3,$Z$3,$AA$3") new list will exclude the cells with zero.

I am running a loop on the solver function so the data changes each time, so I cant simply select the new range each time. I cant select blank cells either. Additionally, formulas are based off each cell so collapsing the range by removing the zeros wont work either. The cells need to be anchored. The rationale for only selecting non-zero cells, is it greatly reduces the calc time. I am doing some heavy modelling that takes about 5 hours to run on a brand new PC.

Actual code is below.

Sub SolveNonLinear1()
    solverreset
    SolverOptions AssumeNonNeg:=False, derivatives:=2, RequireBounds:=False, scaling:=False
    SolverOk SetCell:="$AG$1", MaxMinVal:=1, ValueOf:=0,     ByChange:="$M$3,$N$3,$O$3,$P$3,$Q$3,$R$3,$S$3,$T$3,$U$3,$V$3,$W$3,$X$3,$Y$3,$Z$3,$AA$3",     Engine:=1, EngineDesc:="GRG Nonlinear"
    SolverAdd CellRef:="$AK$12", Relation:=1, FormulaText:="0"
    SolverAdd CellRef:="$AK$13", Relation:=3, FormulaText:="0"
    SolverAdd CellRef:="$M$12:$AA$12", Relation:=1, FormulaText:="0"
    SolverSolve UserFinish:=True
    SolverFinish
End Sub

Siddharth Rout Siddharth Rout · Accepted Answer · 2013-10-29T19:29:59

Try this. What this code does is loops through the supplied range and check if a cell is equal to 0 or not. This function uses the Union method to reconstruct a range

Sub Sample()
    Dim Rng As Range

    Set Rng = GetRange(ThisWorkbook.Sheets("Sheet1").Range("A1:A5"))

    If Not Rng Is Nothing Then
        'Debug.Print Rng.Address
        '
        '~~> Rest of your solver code
        ' ..... ByChange:=Rng.Address ....
    End If
End Sub

Function GetRange(Rng As Range) As Range
    Dim aCell As Range, tmpRng As Range

    For Each aCell In Rng
        If aCell.Value <> 0 Then
            If tmpRng Is Nothing Then
                Set tmpRng = aCell
            Else
                Set tmpRng = Union(tmpRng, aCell)
            End If
        End If
    Next

    If Not tmpRng Is Nothing Then Set GetRange = tmpRng
End Function

Create range in where cells are not equal to zero

1 Answers