How do I output the sets of results from each iteration in a new line in the worksheet? i.e looping through all the possible combinations of (i,j,k,l,m)
avg protein1 = (0,j,k,l,m)
avg protein2 = (1,j,k,l,m)
avg protein3 = (2,j,k,l,m) ...
.. .
avg protein (n-2) = (i,j,k,l,0)
avg protein (n-1) = (i,j,k,l,1)
avg protein (n) = (i,j,k,l,2)
Here's the code from a modified knapsack optimization problem (code works). It maximizes the avg protein value from 5 different bins subject to margin constraint from each bin.
Option Explicit
Sub ProteinCalc()
Dim limit As Double, tol As Double, Protein As Double, Margin As Double, averageprotein As Double, maximumMargin As Double
Dim i, j, k, l, m As Integer
Dim Proteini, Proteinj, Proteink, Proteinl, Proteinm As Double
Dim Margini, Marginj, Margink, Marginl, Marginm As Double
Worksheets("simplecalc").Range("B19:H23").ClearContents
Worksheets("simplecalc").Range("B4:F4").ClearContents
limit = Range("D6").Value 'declare max protein target on blend
tol = Range("G6").Value 'declare tolarance on protein blend to get close to max protien target
maximumMargin = Range("G8").Value 'declare minimum margin $/MT want to make
Proteini = Range("B2").Value
Proteinj = Range("C2").Value
Proteink = Range("D2").Value
Proteinl = Range("E2").Value
Proteinm = Range("F2").Value
Margini = Range("B3").Value
Marginj = Range("C3").Value
Margink = Range("D3").Value
Marginl = Range("E3").Value
Marginm = Range("F3").Value
For i = 0 To 2 'loop up to 2 to signify a possible double spot for train at station i
For j = 0 To 2
For k = 0 To 2
For l = 0 To 2
For m = 0 To 2
Protein = (Proteini * i + Proteinj * j + Proteink * k + Proteinl * l + Proteinm * m) / 5 'linear avg of 5 stations
Margin = (Margini * i + Marginj * j + Margink * k + Marginl * l + Marginm * m) / 5 ' linear avg of margin from 5 stations
If Margin > maximumMargin And Protein <= limit Then
Range("B4").Value = i
Range("C4").Value = j
Range("D4").Value = k
Range("E4").Value = l
Range("F4").Value = m
averageprotein = Protein
maximumMargin = Margin
Debug.Print i
End If
If m >= 0 And m <= 2 Then
Worksheets("simplecalc").Range("B23").Value = averageprotein
Worksheets("simplecalc").Range("C23").Value = Proteini
Worksheets("simplecalc").Range("D23").Value = Proteinj
Worksheets("simplecalc").Range("E23").Value = Proteink
Worksheets("simplecalc").Range("F23").Value = Proteinl
Worksheets("simplecalc").Range("G23").Value = Proteinm
Worksheets("simplecalc").Range("H23").Value = m
Worksheets("simplecalc").Range("i23").Value = l
Worksheets("simplecalc").Range("j23").Value = k
Worksheets("simplecalc").Range("k23").Value = j
Worksheets("simplecalc").Range("l23").Value = i
End If
Next m
If l >= 0 And l <= 2 Then
Worksheets("simplecalc").Range("B22").Value = averageprotein
Worksheets("simplecalc").Range("C22").Value = Proteini
Worksheets("simplecalc").Range("D22").Value = Proteinj
Worksheets("simplecalc").Range("E22").Value = Proteink
Worksheets("simplecalc").Range("F22").Value = Proteinl
Worksheets("simplecalc").Range("G22").Value = Proteinm
Worksheets("simplecalc").Range("H22").Value = l
End If
Next l
If k >= 0 And k <= 2 Then
Worksheets("simplecalc").Range("B21").Value = averageprotein
Worksheets("simplecalc").Range("C21").Value = Proteini
Worksheets("simplecalc").Range("D21").Value = Proteinj
Worksheets("simplecalc").Range("E21").Value = Proteink
Worksheets("simplecalc").Range("F21").Value = Proteinl
Worksheets("simplecalc").Range("G21").Value = Proteinm
Worksheets("simplecalc").Range("H21").Value = k
End If
Next k
If j >= 0 And j <= 2 Then
Worksheets("simplecalc").Range("B20").Value = averageprotein
Worksheets("simplecalc").Range("C20").Value = Proteini
Worksheets("simplecalc").Range("D20").Value = Proteinj
Worksheets("simplecalc").Range("E20").Value = Proteink
Worksheets("simplecalc").Range("F20").Value = Proteinl
Worksheets("simplecalc").Range("G20").Value = Proteinm
Worksheets("simplecalc").Range("H20").Value = j
End If
Next j
If i >= 0 And i <= 2 Then
Worksheets("simplecalc").Range("B19").Value = averageprotein
Worksheets("simplecalc").Range("C19").Value = Proteini
Worksheets("simplecalc").Range("D19").Value = Proteinj
Worksheets("simplecalc").Range("E19").Value = Proteink
Worksheets("simplecalc").Range("F19").Value = Proteinl
Worksheets("simplecalc").Range("G19").Value = Proteinm
Worksheets("simplecalc").Range("H19").Value = i
End If
Next i
Range("B6").Value = averageprotein
Range("B8").Value = maximumMargin
End Sub
You will need to up the row number in every iteration before writing the value to the worksheet. So, declare an iteration counter variable:
Dim itrCount As Long
then change this:
If m >= 0 And m <= 2 Then
Worksheets("simplecalc").Range("B23").Value = averageprotein
Worksheets("simplecalc").Range("C23").Value = Proteini
to this:
If m >= 0 And m <= 2 Then
itrCount = itrCount + 1
Worksheets("simplecalc").Range("B23").Offset(itrCount).Value = averageprotein
Worksheets("simplecalc").Range("C23").Offset(itrCount).Value = Proteini
in every loop accordingly.
That's the minimum needed to make it work, there are other improvements you can apply here.
Related
I created a function that takes a range as an argument and attempts to perform a conditional LOGEST as long as the cell is not blank AND the cell does not have strike through text. However, I cannot get it to run:
Function CustomTrend(rng As Range) As Double
Dim TrendArr() As Variant
Dim ArrSpot As Integer
Dim count, countsq, countsum As Double
Dim LNy, Xsq, XxLNy As Double
Dim last As Integer
last = rng.End(xlDown).row
LNy = 0
Xsq = 0
XxLNy = 0
ArrSpot = 0
count = 0
countsq = 0
countsum = 0
For i = 1 To last Step 1
If rng.Cells(i, 1).Value <> "" And rng.Cells(i, 1).Font.Strikethrough = False Then
ArrSpot = ArrSpot + 1
count = count + 1
TrendArr(ArrSpot) = rng.Cells(i, 1).Value
End If
Next i
For k = ArrSpot To 0 Step -1
LNy = LNy + WorksheetFunction.Ln(TrendArr(ArrSpot))
XxLNy = ArrSpot * WorksheetFunction.Ln(TrendArr(ArrSpot)) + XxLNy
countsq = ArrSpot ^ 2 + countsq
countsum = countsum + ArrSpot
Next k
CustomTrend = (count * XxLNy - countsum * LNy) / (count * countsq - countsum ^ 2)
End Function
Sorted it out on my own, please see revised code below. As a note, I also had to add a .calculatefull into other parts of the code to make sure the function would update when used in a cell.
Function CustomTrend(rng As Range) As Double
Dim count, countsq, countsum As Double
Dim LNy, Xsq, XxLNy As Double
LNy = 0
Xsq = 0
XxLNy = 0
ArrSpot = 0
count = 0
countsq = 0
countsum = 0
For Each cell In rng
If cell.Value <> "" And cell.Font.Strikethrough = False Then
count = count + 1
countsum = countsum + count
LNy = LNy + WorksheetFunction.Ln(cell.Value)
XxLNy = count * WorksheetFunction.Ln(cell.Value) + XxLNy
countsq = count ^ 2 + countsq
End If
Next cell
CustomTrend = (count * XxLNy - countsum * LNy) / (count * countsq - countsum ^ 2)
End Function
The code is working for 3 times in Excel VBA but at the forth time it gives an error. When I put a toggle point there, the code cannot pass "Duration = Duration + drtn" and "Type MisMatch" error shows up. Is there any way to fix the code?
Function simul(t)
Dim wk As Worksheet
Set wk = Worksheets("Simulation")
Dim FoundCell As Range
Duration = 0
i = 1
char = "StartStep"
drtn = 0
While i = 1
m = WorksheetFunction.CountIf(Range("A2:A30"), char)
Set FoundCell = wk.Range("A:A").Find(char)
x = FoundCell.Row
y = FoundCell.Row
Dim myarray() As Variant
ReDim myarray(m)
For j = 0 To m - 1
myarray(j) = wk.Range("E" & x)
x = x + 1
Next
If char = "A" Then
drtn = Application.Evaluate("LOGNORM.INV(RAND(),r5,r6)")
ElseIf char = "B" Then
drtn = Application.Evaluate("ABS(NtLogisticInv(RAND(),r29,r30)")
ElseIf char = "C" Then
drtn = Application.Evaluate("r17*(-LN(1-RAND()))^(1/r18)")
Else
i = 0
drtn = 0
End If
Duration = Duration + drtn
r = Rnd()
k = 0
While r > myarray(k)
k = k + 1
Wend
char = wk.Range("B" & y + k)
Wend
wk.Range("U" & t) = Duration
End Function
I am creating an Excel pie and bar charts from exported data pragmatically. Here I need to pick the cell range dynamically. For example, after header name all data should be picked up until cell contains "TOTAL" line.
Below is my current code.
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("oversight")) Then 'This is Summary Level
Dim worksheet2 As ExcelWorksheet = pkg.Workbook.Worksheets.Add("Chart - CY Consumable")
worksheet2.DefaultColWidth = 15
Dim consumableChart As OfficeOpenXml.Drawing.Chart.ExcelPieChart = worksheet2.Drawings.AddChart("ConsumableChart", OfficeOpenXml.Drawing.Chart.eChartType.Pie)
Dim r1, r2 As ExcelRange
r1 = worksheet.Cells("A6:A12") // here I want it to be selected dynamically after header and before the total line
r2 = worksheet.Cells("B6:B12")
consumableChart.Series.Add(r2, r1)
consumableChart.Style = OfficeOpenXml.Drawing.Chart.eChartStyle.Style2
consumableChart.Title.Text = "FY 2018 Consumable by Regional & Central Oversight Programs"
consumableChart.Legend.Remove()
consumableChart.SetPosition(1, 1, 1, 1)
consumableChart.SetSize(1040, 880)
consumableChart.DataLabel.ShowLeaderLines = True
consumableChart.DataLabel.ShowCategory = True
consumableChart.DataLabel.ShowPercent = True
Thanks in advance.
Dim totalRow As Integer
If ds.Tables.Count > 0 Then
Dim k As Integer = 0
For j As Integer = 0 To ds.Tables(0).Columns.Count - 1
If Not skip.Contains(j) Then
If columnNames.Count > 0 AndAlso columnNames.Count = (ds.Tables(0).Columns.Count - skip.Count) Then
strTitle = columnNames(k)
Else
strTitle = ds.Tables(0).Columns(j).ColumnName.Replace("_", " ")
End If
worksheet.Cells(p, k + 1).Value = strTitle
k = k + 1
End If
Next
Dim i As Integer = p + 1
For Each r As DataRow In ds.Tables(0).Rows
If includeTotals OrElse (Not r.Item(2).ToString().Trim().ToUpper().StartsWith("TOTAL") AndAlso _
Not r.Item(2).ToString().Trim().ToUpper().StartsWith("SUBTOTAL") AndAlso _
Not r.Item(2).ToString().Trim().ToUpper().StartsWith("TOTAL") AndAlso _
Not r.Item(2).ToString().Trim().ToUpper().StartsWith("SUBTOTAL")) Then
k = 0
For j As Integer = 0 To ds.Tables(0).Columns.Count - 1
If Not skip.Contains(j) Then
If r.Item(j) Is DBNull.Value Then
worksheet.Cells(i, k + 1).Value = ""
Else
If k = 0 Then
worksheet.Cells(i, k + 1).Style.Numberformat.Format = "#"
worksheet.Cells(i, k + 1).Value = r.Item(j).ToString()
Else
worksheet.Cells(i, k + 1).Value = r.Item(j)
End If
End If
// Checking if it is first col last row
If r.Item(j).ToString().Contains("TOTAL") Then
totalRow = i
End If
If r.Item(j).GetType().Name = "Decimal" Then
If roundUp Then
If useParens Then
worksheet.Cells(i, k + 1).StyleID = 2
Else
worksheet.Cells(i, k + 1).StyleID = 2 '4
End If
Else
If useParens Then
worksheet.Cells(i, k + 1).StyleID = 1
Else
worksheet.Cells(i, k + 1).StyleID = 1 '3
End If
End If
End If
k = k + 1
End If
Next
i = i + 1
End If
Next
End If
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("oversight")) Then 'This is Summary Level
Dim worksheet2 As ExcelWorksheet = pkg.Workbook.Worksheets.Add("Chart - CY Consumable")
worksheet2.DefaultColWidth = 15
// showing the criteria
p = 1
If includeCriteria Then
Try
Dim reportTitle As String = String.Empty
reportTitle = "Central/Regional Oversight Programs"
Dim sb As StringBuilder = New StringBuilder()
sb.Append(reportTitle)
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
sb.Append("Budget Fiscal Year : ")
sb.Append(HttpContext.Current.Session("bfy"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
sb.Append("Currently viewing transactions from inception through ")
Dim fm As Integer = CInt(HttpContext.Current.Session("fm"))
If fm < 4 Then
sb.Append(MonthName(fm + 9))
sb.Append(" ")
sb.Append(CInt(HttpContext.Current.Session("fy")) - 1)
Else
sb.Append(MonthName(fm - 3))
sb.Append(" ")
sb.Append(HttpContext.Current.Session("fy"))
End If
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("division")) Then
sb.Append("Fund Center(s) : ALL")
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
Else
sb.Append("Fund Center(s) : ")
sb.Append(HttpContext.Current.Request.QueryString("division"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
End If
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("fa5")) Then
sb.Append("Func Area 5 : ALL")
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
Else
sb.Append("Func Area 5 : ")
sb.Append(HttpContext.Current.Request.QueryString("fa5"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
End If
If Not String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("oversight")) Then
sb.Append("Oversight Program - ")
sb.Append(HttpContext.Current.Request.QueryString("oversight"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
End If
sb.Append("FBMS data as of ")
sb.Append(HttpContext.Current.Application("lastUpdated_BIA"))
sb.Append(" at close of business.")
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
worksheet2.Cells(p, 1).Value = ""
p = p + 1
Catch ex As Exception
For r As Integer = 1 To p - 1
worksheet2.DeleteRow(1, True)
Next
p = 1
End Try
End If
//create chart in new tab
Dim consumableChart As OfficeOpenXml.Drawing.Chart.ExcelPieChart = worksheet2.Drawings.AddChart("ConsumableChart", OfficeOpenXml.Drawing.Chart.eChartType.Pie)
Dim r1, r2 As ExcelRange
// setting the value to check the last row
Dim startColumn As String = "A"
Dim endColumn As String = "B"
Dim startIndex As Integer = 8 // Index where to start
Dim endIndex As Integer = totalRow - 1 'this is determined based on the TOTAL Line from above code
// checking and setting the values and label of pie chart
r1 = worksheet.Cells(String.Concat(startColumn, startIndex.ToString(), ":", startColumn, endIndex))
r2 = worksheet.Cells(String.Concat(endColumn, startIndex.ToString(), ":", endColumn, endIndex))
consumableChart.Series.Add(r2, r1)
consumableChart.Style = OfficeOpenXml.Drawing.Chart.eChartStyle.Style2
consumableChart.Title.Text = "FY 2018 Consumable by Regional & Central Oversight Programs"
consumableChart.Legend.Remove()
consumableChart.SetPosition(5, 5, 5, 5)
consumableChart.SetSize(1040, 880)
consumableChart.DataLabel.ShowLeaderLines = True
consumableChart.DataLabel.ShowCategory = True
consumableChart.DataLabel.ShowPercent = True
I have a single box with sides l, w, h (natural numbers). I have to pack this standard box to the BIN under constraints: Longest BIN side <=150, Longest BIN side + 2*(sum of other 2 sides)<=300. Based on Lagrange Multipliers the maximum BIN volume and length of sides under these constraints are 100x50x50=250000. The optimal BIN sides should be close to 100x50x50 and must have maximum volume. Now the below code works, but for a box with small sides it is taking more time. For example, if box sides are 1x1x1, then it calculates all options 150x150x150 under above constraints. If anybody has better idea how to improve this code, please help.
`Sub Macro1()
l = Sheets("list").Range("a" & 2)'45
w = Sheets("list").Range("b" & 2)'20
h = Sheets("list").Range("c" & 2)'30
result = 150 / l
ll = Math.Round(150 / l, 0)
If result <> ll Then
ll = ll + 1
Else
End If
result = 150 / w
lw = Math.Round(150 / w, 0)
If result <> lw Then
lw = lw + 1
Else
End If
result = 150 / h
lh = Math.Round(150 / h, 0)
If result <> lh Then
lh = lh + 1
Else
End If
Dim londis() As Double
Dim shortdis() As Double
Dim options() As Double
ReDim options(lw * ll * lh)
ReDim longdis(lw * ll * lh)
ReDim shortdis(lw * ll * lh)
k = 6
s = 0
`
For i = 0 To lh
For j = 0 To lw
For n = 0 To ll
summa = i * h + j * w + n * l
If summa <= 150 Then
'Sheets("list").Range("a" & k) = summa
s = s + 1
options(s) = summa
'longdis(s) = 100 - summa
'shortdis(s) = 50 - summa
If summa > 100 Then
longdis(s) = 100 - summa
Else
longdis(s) = summa - 100
End If
If summa <= 50 Then
shortdis(s) = summa - 50
Else
shortdis(s) = 50 - summa
End If
k = k + 1
Else
GoTo 1
End If
Next n
1:
Next j
Next i
For i = 1 To s - 1
For j = i + 1 To s
If shortdis(i) < shortdis(j) Then
pTemp1 = options(i)
pTemp2 = longdis(i)
pTemp3 = shortdis(i)
options(i) = options(j)
shortdis(i) = shortdis(j)
longdis(i) = longdis(j)
options(j) = pTemp1
longdis(j) = pTemp2
shortdis(j) = pTemp3
Else
End If
Next j
Next i
t = 1
maxVol = 0
pT = 0
pL = 0
prodVol = l * w * h
maxPosUnit = Int(250000 / prodVol)
maxPosVol = maxPosUnit * prodVol
Do While t < s - 2
longside = 300 - 2 * (options(t) + options(t + 1))
For i = 1 To s
If options(i) <= longside Then
vol = options(i) * options(t) * options(t + 1)
If vol > maxVol Then
maxVol = vol
pT = t
pL = i
Else
End If
Else
End If
If options(i) = longside Then
Exit Do
End If
Next i
t = t + 1
Loop
Sheets("list").Range("d" & 2) = prodVol
Sheets("list").Range("e" & 2) = maxPosUnit
'Sheets("list").Range("f" & 2) = 250000 - maxPosVol
Sheets("list").Range("a" & 3) = options(pT)
Sheets("list").Range("b" & 3) = options(pT + 1)
Sheets("list").Range("c" & 3) = options(pL)
boxVol = options(pT) * options(pT + 1) * options(pL)
Sheets("list").Range("d" & 3) = boxVol
Sheets("list").Range("e" & 3) = Int(boxVol / prodVol)
Sheets("list").Range("f" & 3) = boxVol - Int(boxVol / prodVol) * prodVol
End Sub
I want this code to search the column name called((attribute value1,attribute value2..N)
If that column contains fraction values, it should convert it to decimal. I'm using this macros(VBA).
The code is working but it is converting only one column(attribute value1).
It will take more time because I have multiple columns(attribute value2...N) that have fraction values.
Please help me out I am struck here.
Sub deci()
Dim LR As Long
Dim Dash As Long
Dim Whole As Double
Dim lngDataColumn As Long
Dim pi
lngDataColumn = 4
Sheets("Sheet3").Select
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
For r = 2 To LR
s = Cells(r, lngDataColumn)
arr = Split(s, ",")
For i = LBound(arr) To UBound(arr)
Whole = 0
P = InStr(arr(i), " IN")
If P > 0 Then
Worksheet = (Left((arr(i)), P - 1))
Else
Worksheet = arr(i)
End If
Dash = InStr(Worksheet, "-")
If Dash > 0 Then
Whole = Frac(Left(Worksheet, Dash - 1))
Worksheet = Mid(Worksheet, Dash + 1)
End If
af = Right(arr(i), Len(arr(i)) - P + 1)
evfrac = Whole + Left(CStr(Evaluate(Worksheet)), 5)
' evfrac = Whole + Format(Evaluate(frac), "0.###")
ss = ss & evfrac & af & ", "
Next i
Cells(r, lngDataColumn) = Left(ss, Len(ss) - 2)
ss = ""
Next r
End Sub
Function Frac(ByVal X As String) As Double
Dim P As Integer, N As Double, Num As Double, Den As Double
X = Trim$(X)
P = InStr(X, "/")
If P = 0 Then
N = Val(X)
Else
Den = Val(Mid$(X, P + 1))
If Den = 0 Then Err.Raise 11 ' Divide by zero
X = Trim$(Left$(X, P - 1))
P = InStr(X, " ")
If P = 0 Then
Num = Val(X)
Else
Num = Val(Mid$(X, P + 1))
N = Val(Left$(X, P - 1))
End If
End If
If Den <> 0 Then
N = N + Num / Den
End If
Frac = N
End Function
The reason it's only doing one column is because that's exactly what your telling it to do with this section of the code:
lngDataColumn = 4
Sheets("Sheet3").Select
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
Because your setting lngDataColumn as a fixed figure, your code is only executed on column 4. If you want to do more columns as a loop, you need to increment this value in the same maner you are incrementing r in your for loop.
For example:
lngDataColumn = 10
Sheets("Sheet3").Select
For 4 To lngDataColumn
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
'Rest of code
Next lngDataColumn