Dim rng As Range
Dim r1 As Integer, c1 As Integer
Dim ws As Worksheet
Dim r2 As Integer, c2 As Integer
Dim i, j As Integer
Private Sub GetUsedRange()
'Get used range
Set rng = ws.UsedRange
r1 = rng.Row
r2 = rng.Rows.Count + r1 - 1
c1 = rng.Column
c2 = rng.Columns.Count + c1 - 1
End Sub
Private Sub SetCellValue(rw As Long, col As Integer, cellValue As String)
ws.Cells(rw, col).Value = cellValue
ws.Cells(rw, col).Font.Bold = True
End Sub
Private Sub InitializeArray(ByRef leftArray As Variant, leftLoopTo As Integer, rightArray As Variant, rightLoopTo As Integer)
'Initialize array A with values from range Arng
For i = 1 To leftLoopTo
For j = 1 To rightLoopTo
leftArray(i, j) = rightArray(i, j)
Next j
Next i
End Sub
Private Sub LargeSubroutine()
UserForm1.Show
ReDim A(1 To NumberOfCampaigns, 1 To NumberOfQualities) As Variant
ReDim ATRANSPOSE(1 To NumberOfQualities, 1 To NumberOfCampaigns) As Variant
ReDim ATRANSPOSEA(1 To NumberOfQualities, 1 To NumberOfQualities) As Variant
ReDim ATRANSPOSEB(1 To NumberOfQualities, 1 To 1) As Variant
ReDim XATRANSPOSEB(1 To 1) As Variant
ReDim B(1 To NumberOfCampaigns, 1 To 1) As Variant
ReDim BTRANSPOSE(1 To 1, 1 To NumberOfCampaigns) As Variant
ReDim X(1 To 1, 1 To NumberOfQualities) As Variant
If Arng Is Nothing Then Exit Sub
Set ws = ActiveSheet
ws.Activate
GetUsedRange
'Print A matrix below used range
SetCellValue r2 + 2, c1, "A MATRIX"
SetCellValue r2 + 2, c1 + NumberOfQualities + 2, "A TRANSPOSE MATRIX"
Set rng = Range(Cells(r2 + 3, c1), Cells(r2 + 3 + NumberOfCampaigns - 1, c1 + NumberOfQualities - 1))
Arng.Copy rng
rng.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
'Initialize array A with values from range Arng
InitializeArray A, NumberOfCampaigns, Arng, NumberOfQualities
ATRANSPOSE = WorksheetFunction.Transpose(A)
r1 = r2 + 3
c1 = c1 + NumberOfQualities + 1
r2 = r2 + 3 + NumberOfQualities - 1
c2 = c1 + NumberOfCampaigns - 1
Set ATRANSPOSErng = Range(Cells(r1, c1), Cells(r2, c2))
InitializeArray ATRANSPOSErng, NumberOfQualities, ATRANSPOSE, NumberOfCampaigns
ATRANSPOSErng.Select
Selection.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
'Get used range
Set rng = ws.UsedRange
'Print B next to A TRANSPOSE
SetCellValue r1 - 1, c2 + 2, "b MATRIX"
For i = 1 To NumberOfCampaigns
ActiveSheet.Cells(r1 + i - 1, c2 + 2).Value = 1
B(i, 1) = 1#
Next i
BTRANSPOSE = WorksheetFunction.Transpose(B)
Set Brng = Range(Cells(r1, c2 + 2), Cells(r1 + NumberOfCampaigns - 1, c2 + 2))
Brng.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
'Print ATRANA next to ATRAN
GetUsedRange
SetCellValue r2 + 2, c1, "PRODUCT OF A TRANSPOSE AND A"
ATRANSPOSEA = WorksheetFunction.MMult(ATRANSPOSE, A)
Set ATRANSPOSEArng = Range(Cells(r2 + 3, c1), Cells(r2 + 3 + NumberOfQualities - 1, c1 + NumberOfQualities - 1))
InitializeArray ATRANSPOSEArng, NumberOfQualities, ATRANSPOSEA, NumberOfQualities
ATRANSPOSEArng.Select
Selection.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
' Print ATRANSPOSE b next to ATRANSPOSEA
SetCellValue r2 + 2, c1 + NumberOfQualities + 1, "PRODUCT OF A TRANSPOSE AND b"
ATRANSPOSEB = WorksheetFunction.MMult(ATRANSPOSE, B)
Set ATRANSPOSEBrng = Range(Cells(r2 + 3, c1 + NumberOfQualities + 1), Cells(r2 + 3 + NumberOfQualities - 1, c1 + NumberOfQualities + 1))
For i = 1 To NumberOfQualities
ATRANSPOSEBrng(i) = ATRANSPOSEB(i, 1)
Next i
ATRANSPOSEBrng.Select
Selection.BorderAround LineStyle:=xlContinuous, Weight:=xlThin
GetUsedRange
SetCellValue r2 + 2, c1, "CONSUMPTION OF REFRACTORY MATERIAL PER TONNE OF EACH QUALITY"
Set Xrng = Range(Cells(r2 + 3, c1), Cells(r2 + 3, c1 + NumberOfQualities - 1))
Xrng.Select
Xrng.BorderAround LineStyle:=xlContinuous, Weight:=xlThick, Color:=vbRed
' Initialize array X to zeros
For i = 1 To NumberOfQualities
Xrng(1, i) = i / NumberOfQualities
X(1, i) = Xrng(1, i)
Next i
SetCellValue "Objective Function"
' Initialize objective function cell with formula intact.:banghead:
' The FormulaArray requires R1C1 notation. There is a range.Address
' property that returns the R1C1 coordinates for the particular range in quotes.
ws.Cells(r2 + 3, c1 + NumberOfQualities + 1).Select
Selection.FormulaArray = WorksheetFunction.MMult(Xrng, Application.WorksheetFunction.MMult(ATRANSPOSEArng, Application.WorksheetFunction.Transpose(Xrng)))
Selection.BorderAround LineStyle:=xlDouble
ws.Cells(r2 + 4, c1 + NumberOfQualities + 1).Select
Selection.FormulaArray = WorksheetFunction.MMult(Xrng, ATRANSPOSEBrng)
Selection.BorderAround LineStyle:=xlDouble
GetUsedRange
SetCellValue r2 + 2, c1, "X CONSTRAINED TO BE POSITIVE"
Set Constraintrng = Range(Cells(r2 + 3, c1), Cells(r2 + 3 + NumberOfQualities - 1, c1 + 2))
Constraintrng.Select
For i = 1 To NumberOfQualities
Constraintrng(i, 1).Formula = Xrng(1, i)
Constraintrng(i, 2) = ">="
Constraintrng(i, 3) = 0.001
Next i
Selection.BorderAround LineStyle:=xlContinuous, Weight:=xlThin, Color:=vbBlue
Exit Sub
' Calls to the Solver family of functions with the correct arguments.
' A path reference to the add-in location is available for these calls.
' MaxMinVal in SolverOk(SetCell, MaxMinVal, ValueOf, ByChange) calls can take on the following values
' 1 is maximize
' 2 is minimize
' 3 is match a value
' Relation in SolverAdd(cellref, Relation, Formulatext) calls can taken on the following values
' 1 is <=
' 2 is =
' 3 is >=
' 4 is integer valued
' 5 is binary valued
SolverOk SetCell:=Selection.Address, MaxMinVal:=2, ValueOf:="0", ByChange:=Xrng.Address
For i = 1 To NumberOfQualities
SolverAdd CellRef:=Constraintrng(i, 1).Address, Relation:=3, FormulaText:=Constraintrng(i, 3).Address
Next i
SolverOptions MaxTime:=100, Iterations:=100, Precision:=0.000001, AssumeLinear _
:=False, StepThru:=False, Estimates:=1, Derivatives:=1, SearchOption:=1, _
IntTolerance:=5, Scaling:=False, Convergence:=0.0001, AssumeNonNeg:=True
SolverSolve
End Sub
edit: forgot to update the initial sub with the loop to number