I'm trying to get my VBA code to output a graph in excel based on an inputted range that was selected using a user defined function from multiple cells. I've passed the data to the sub as a range but it ends up assuming that the range is two data sets rather than one data set with x and y values. The data set is selected from excel into a function that is being written separately which then calls the sub.
Sub CreateChart(ByRef r As Range)
Dim cht As Object
Set cht = ActiveSheet.Shapes.AddChart2
cht.Chart.SetSourceData Source:=r
cht.Chart.ChartType = xlXYScatterLines
End Sub
I called the sub through
Call CreateChart(r)
with r being a two column range of data that was selected from excel.
Public Function cubic(ByVal r As Range, x As Double, Optional check As Integer = 1) As Double
The overall function code is here as well
Public Function cubic(ByVal r As Range, x As Double, Optional check As Integer = 1) As Double
Dim data() As Double
Dim check1 As Integer
Dim Smatrix() As Double
Dim Tmatrix() As Double
Dim Xmatrix() As Double
Dim Amatrix() As Double
Dim Hmatrix() As Double
Dim m As Integer
Dim i As Integer
m = r.Rows.Count
ReDim data(1 To m, 2)
ReDim Smatrix(1 To m, 1 To m)
ReDim Tmatrix(1 To m, 4)
ReDim Xmatrix(1 To m)
ReDim Amatrix(1 To m - 1, 1 To 4)
ReDim Hmatrix(1 To m)
check1 = Test(check)
For i = 1 To m
data(i, 1) = r(i, 1).Value
data(i, 2) = r(i, 2).Value
Next i
Smatrix(1, 1) = 1
Smatrix(m, m) = 1
For i = 1 To m - 1
Hmatrix(i) = data(i + 1, 1) - data(i, 1)
Next i
If check1 = 2 Then
Smatrix(1, 2) = -1
Smatrix(m, m - 1) = -1
End If
For i = 2 To m - 1
Smatrix(i, i - 1) = Hmatrix(i - 1)
Smatrix(i, i + 1) = Hmatrix(i)
Smatrix(i, i) = 2 * (Hmatrix(i - 1) + Hmatrix(i))
Next i
For i = 2 To m - 1
Tmatrix(i, 4) = 6 * ((data(i + 1, 2) - data(i, 2)) / Hmatrix(i) - (data(i, 2) - data(i - 1, 2)) / Hmatrix(i - 1))
Next i
For i = 1 To m
If i <> 1 Then
Tmatrix(i, 1) = Smatrix(i, i - 1)
End If
Tmatrix(i, 2) = Smatrix(i, i)
If i <> m Then
Tmatrix(i, 3) = Smatrix(i, i + 1)
End If
Next i
For i = 2 To m
Tmatrix(i, 1) = Tmatrix(i, 1) / Tmatrix(i - 1, 2)
Tmatrix(i, 2) = Tmatrix(i, 2) - Tmatrix(i, 1) * Tmatrix(i - 1, 3)
Tmatrix(i, 4) = Tmatrix(i, 4) - Tmatrix(i, 1) * Tmatrix(i - 1, 4)
Next i
Xmatrix(m) = Tmatrix(m, 4) / Tmatrix(m, 2)
For i = m - 1 To 1 Step -1
Xmatrix(i) = (Tmatrix(i, 4) - Tmatrix(i, 3) * Xmatrix(i + 1)) / Tmatrix(i, 2)
Next i
For i = 1 To m - 1
Amatrix(i, 1) = (Xmatrix(i + 1) - Xmatrix(i)) / 6 * Hmatrix(i)
Amatrix(i, 2) = Xmatrix(i) / 2
Amatrix(i, 3) = (data(i + 1, 2) - data(i, 2)) / Hmatrix(i) - Hmatrix(i) * Xmatrix(i) / 2 - Hmatrix(i) * (Xmatrix(i + 1) - Xmatrix(i)) / 6
Amatrix(i, 4) = data(i, 2)
Next i
If x < data(1, 1) Or x > data(m, 1) Then
Call Check2(x)
If x < data(1, 1) Then
cubic = Amatrix(1, 1) * (x - data(1, 1)) ^ 3 + Amatrix(1, 2) * (x - data(1, 1)) ^ 2 + Amatrix(1, 3) * (x - data(1, 1)) + Amatrix(1, 4)
ElseIf x > data(m, 1) Then
cubic = Amatrix(m - 1, 1) * (x - data(m - 1, 1)) ^ 3 + Amatrix(m - 1, 2) * (x - data(m - 1, 1)) ^ 2 + Amatrix(m - 1, 3) * (x - data(m - 1, 1)) + Amatrix(m - 1, 4)
End If
ElseIf x = data(m, 1) Then
cubic = data(m, 2)
Else
For i = 1 To m - 1
If data(i, 1) < x And x < data(i + 1, 1) Then
cubic = Amatrix(i, 1) * (x - data(i, 1)) ^ 3 + Amatrix(i, 2) * (x - data(i, 1)) ^ 2 + Amatrix(i, 3) * (x - data(i, 1)) + Amatrix(i, 4)
ElseIf x = data(i, 1) Then
cubic = data(i, 2)
End If
Next i
End If
Call CreateChart(r)
End Function
As well as the subroutine and function called within the function that haven't been posted
Public Function Test(check As Integer) As Integer
Dim Response As Integer
If check = 1 Then
Response = MsgBox("Boundary Condition 1 selected, is this correct (select No for boundary condition 2)?", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 1
Else
Test = 2
End If
ElseIf check = 2 Then
Response = MsgBox("Boundary Condition 2 selected, is this correct (select No for boundary condition 1)?", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 2
Else
Test = 1
End If
Else
Response = MsgBox("Incorrect Boundary Condition, select Yes for condition 1 and No for condition 2", vbYesNo, "Boundary Conditions")
If Response = 6 Then
Test = 1
Else
Test = 2
End If
End If
End Function
Public Sub Check2(x)
MsgBox ("Value given is outside data range, answer may not be correct, extrapolating from calculated polynomial")
End Sub
Try
Sub CreateChart(ByRef r As Range)
Dim cht As Object
Set cht = ActiveSheet.Shapes.AddChart2(XlChartType:=xlXYScatterSmooth)
cht.Chart.SetSourceData Source:=r
End Sub
Related
Sub WriteToZeroBasedArray()
Dim E As Integer
Dim rCount As Long: rCount = Worksheets("0618").Cells.SpecialCells(xlLastCell).Row
For E = 9 To 11
Dim V() As Variant ' Note the parentheses!
Dim P() As Variant
Dim N() As Variant
Dim Index As Long
Dim Index_2 As Long
Dim Index_3 As Long
Dim cCount As Long: cCount = Worksheets("0618").Cells.SpecialCells(xlLastCell).Column ' e.g.
Dim c As Long '배열에 값 저장하기
For c = 7 To cCount
If 0 < Worksheets("0618").Cells(E, c).Value And Worksheets("0618").Cells(E, c).Value < 100 Then
ReDim Preserve V(Index)
' A safer way (Option Base related):
'ReDim Preserve V(0 To Index)
V(Index) = Worksheets("0618").Cells(2, c).Value
Index = Index + 1
ReDim Preserve P(Index_2)
P(Index_2) = Worksheets("0618").Cells(4, c).Value
Index_2 = Index_2 + 1
ReDim Preserve N(Index_3)
N(Index_3) = Worksheets("0618").Cells(E, c).Value
Index_3 = Index_3 + 1
End If
Next c
Dim K As Integer
Dim L As Integer
K = UBound(V) '배열의 값 차례로 Sheet2에 넣기
For L = 0 To K
If L < 5 Then
Worksheets("sheet2").Cells(L + 6 + 14 * (E - 9), 1).Value = V(L)
Worksheets("sheet2").Cells(L + 6 + 14 * (E - 9), 2).Value = P(L)
Worksheets("sheet2").Cells(L + 6 + 14 * (E - 9), 3).Value = N(L)
Else
Worksheets("sheet2").Cells(L + 1 + 14 * (E - 9), 5).Value = V(L)
Worksheets("sheet2").Cells(L + 1 + 14 * (E - 9), 6).Value = P(L)
Worksheets("sheet2").Cells(L + 1 + 14 * (E - 9), 7).Value = N(L)
End If
Next
Dim FP As Integer
Dim Sum As Integer
Sum = 0
'수량*단가 구하기
For FP = (6 + 14 * (E - 9)) To (10 + 14 * (E - 9))
Worksheets("sheet2").Cells(FP, 4).Value = Worksheets("sheet2").Cells(FP, 2).Value * Worksheets("sheet2").Cells(FP, 3).Value
Worksheets("sheet2").Cells(FP, 8).Value = Worksheets("sheet2").Cells(FP, 6).Value * Worksheets("sheet2").Cells(FP, 7).Value
'총액 구하기
Sum = Sum + Worksheets("sheet2").Cells(FP, 4).Value + Worksheets("sheet2").Cells(FP, 8).Value
'0 지우기
If Worksheets("sheet2").Cells(FP, 4).Value = 0 Then
Worksheets("sheet2").Cells(FP, 4).ClearContents
End If
If Worksheets("sheet2").Cells(FP, 8).Value = 0 Then
Worksheets("sheet2").Cells(FP, 8).ClearContents
End If
Next
'총액 구하기2
Worksheets("sheet2").Cells(12 + 14 * (E - 9), 8).Value = Sum
'받으실 분
Worksheets("sheet2").Cells(3 + 14 * (E - 9), 2).Value = Worksheets("0618").Cells(E, 3).Value
'주소
Worksheets("sheet2").Cells(3 + 14 * (E - 9), 5).Value = Worksheets("0618").Cells(E, 2).Value
'서식 복사'
Worksheets("sheet3").Range("A1:H13").Copy
Worksheets("sheet2").Range("A" & 15 + 14 * (E - 9)).PasteSpecial
If Index = 0 Then Exit Sub
Next
Debug.Print Join(V, vbLf)
End Sub
I expected this code to be like this
But the result is like this
When E = 9, the code runs exactly the same as I thought, but when E is over 10, it doesn't.
when E = 9, the V array's values and orders are like this [grape, apple], and that's what I wanted.
However, when E = 10, I want the V array's value to be like this [orange]
but the result says it is [ , , orange]
Could someone tell me what's wrong with my code?
For me, the two (different) pictures look like 'Chinese'... So, I cannot refer to them.
No need to use Index, Index2 and Index3. Use only Index and increment it at the second loop end;
'replace this line
Index_3 = Index_3 + 1
'with
Index = Index + 1
' and comment all the previous index incrementations
You must reinitialize the used arrays content and used Index at the first loop end:
'your code...
If Index = 0 Then Exit Sub 'after this existing code line
Erase V: Erase P: Erase N: Index = 0
Next
'Your code
Now, using Redim Preserve to often is bad from memory handling point of view. Please, try firstly ReDim to a value to exceed the necessary number of necessary elements (ReDim V(cCount)) and use only of the end: Redim Preserve V(Index -1). Do the same for the other two used arrays...
I have a portfolio report I build from VBA code on monthly and ad-hoc basis. It works fine today, but the underlying VBA is far from optimized. The code sniplet below is repeated 5 times as there are 5 projects in the system now, but it will grow to 50 shortly. Is there anyone that have suggestions as to how I can utilize VBA more elegantly performing the copying to the locations specified in the code (see sniplet below)
Sub CreatePortFolio()
Application.ScreenUpdating = False
'Clears old data
Application.Goto Reference:="PFData" 'Named range in the portfolio overview sheet
Selection.ClearContents
'************* Project 1
If Not Sheets(Sheets.Count).Range("BG1").Value = "" Then
Ark4.Range("B5").Value = Sheets(Sheets.Count).Range("BG1").Value 'Ark4 is the portfolio report and the sheets.count is used to pick the latest import of data - always in the same format
Ark4.Range("C5").Value = Sheets(Sheets.Count).Range("BF1").Value
Ark4.Range("D5").Value = Sheets(Sheets.Count).Range("BH1").Value
Ark4.Range("E5").Value = Sheets(Sheets.Count).Range("AU1").Value
Ark4.Range("F5").Value = Sheets(Sheets.Count).Range("AU2").Value
Ark4.Range("G5").Value = Sheets(Sheets.Count).Range("AU3").Value
Ark4.Range("H5").Value = Sheets(Sheets.Count).Range("AV1").Value
Ark4.Range("I5").Value = Sheets(Sheets.Count).Range("AV2").Value
Ark4.Range("J5").Value = Sheets(Sheets.Count).Range("AV3").Value
Ark4.Range("L4").Value = Sheets(Sheets.Count).Range("AP3").Value
Ark4.Range("L5").Value = Sheets(Sheets.Count).Range("AP4").Value
Ark4.Range("L6").Value = Sheets(Sheets.Count).Range("AP5").Value
Ark4.Range("M4").Value = Sheets(Sheets.Count).Range("AQ3").Value
Ark4.Range("M5").Value = Sheets(Sheets.Count).Range("AQ4").Value
Ark4.Range("M6").Value = Sheets(Sheets.Count).Range("AQ5").Value
Ark4.Range("N4").Value = Sheets(Sheets.Count).Range("AR3").Value
Ark4.Range("N5").Value = Sheets(Sheets.Count).Range("AR4").Value
Ark4.Range("N6").Value = Sheets(Sheets.Count).Range("AR5").Value
Ark4.Range("O4").Value = Sheets(Sheets.Count).Range("AS3").Value
Ark4.Range("O5").Value = Sheets(Sheets.Count).Range("AS4").Value
Ark4.Range("O6").Value = Sheets(Sheets.Count).Range("AS5").Value
Ark4.Range("Q4").Value = Sheets(Sheets.Count).Range("AP10").Value
Ark4.Range("Q5").Value = Sheets(Sheets.Count).Range("AP11").Value
Ark4.Range("Q6").Value = Sheets(Sheets.Count).Range("AP12").Value
Ark4.Range("R4").Value = Sheets(Sheets.Count).Range("AQ10").Value
Ark4.Range("R5").Value = Sheets(Sheets.Count).Range("AQ11").Value
Ark4.Range("R6").Value = Sheets(Sheets.Count).Range("AQ12").Value
Ark4.Range("S4").Value = Sheets(Sheets.Count).Range("AR10").Value
Ark4.Range("S5").Value = Sheets(Sheets.Count).Range("AR11").Value
Ark4.Range("S6").Value = Sheets(Sheets.Count).Range("AR12").Value
Ark4.Range("T4").Value = Sheets(Sheets.Count).Range("AS10").Value
Ark4.Range("T5").Value = Sheets(Sheets.Count).Range("AS11").Value
Ark4.Range("T6").Value = Sheets(Sheets.Count).Range("AS12").Value
Ark4.Range("U5").Value = Sheets(Sheets.Count).Range("AW4").Value
Ark4.Range("V5").Value = Sheets(Sheets.Count).Range("AW3").Value
End If
'******* I Want to avoid copying the above code 50 times *******
Application.ScreenUpdating = True
End Sub
The Portfolio report look like this:
The data sheet to build the report from look like this:
Try,
Sub test()
Dim wsData As Worksheet
Dim Ws As Worksheet
Dim vDB As Variant
Dim vR() As Variant
Dim Ark4 As Worksheet
Dim i As Long, n As Long, r As Long
Set Ark4 = Sheets(1) ' set your sheets
Set wsData = Sheets(Sheets.Count)
With wsData
r = .Range("BG" & Rows.Count).End(xlUp).Row + 11
vDB = .Range("ap1", "bh" & r)
End With
For i = 1 To r Step 12
If vDB(i, 18) <> "" Then
n = n + 3
ReDim Preserve vR(1 To 21, 1 To n)
'Column b ~ j
vR(1, n - 2) = vDB(i, 18) 'bg1
vR(2, n - 2) = vDB(i, 17) 'bf1
vR(3, n - 2) = vDB(i, 19)
vR(4, n - 2) = vDB(i, 6)
vR(5, n - 2) = vDB(i + 1, 6)
vR(6, n - 2) = vDB(i + 2, 6)
vR(7, n - 2) = vDB(i, 7)
vR(8, n - 2) = vDB(i + 1, 7)
vR(9, n - 2) = vDB(i + 2, 7)
'Column k ~ o
vR(10, n - 2) = "Budget"
vR(10, n - 1) = "Installemnt"
vR(10, n) = "Deviation"
vR(11, n - 2) = vDB(i + 2, 1) 'ap3
vR(11, n - 1) = vDB(i + 3, 1) 'ap4
vR(11, n) = vDB(i + 4, 1) 'ap5
vR(12, n - 2) = vDB(i + 2, 2) 'aq3
vR(12, n - 1) = vDB(i + 3, 2) 'aq4
vR(12, n) = vDB(i + 4, 2) 'aq5
vR(13, n - 2) = vDB(i + 2, 3) 'ar3
vR(13, n - 1) = vDB(i + 3, 3) 'ar4
vR(13, n) = vDB(i + 4, 3) 'ar5
vR(14, n - 2) = vDB(i + 2, 4) 'as3
vR(14, n - 1) = vDB(i + 3, 4) 'as4
vR(14, n) = vDB(i + 4, 4) 'as5
'Column p ~ z
vR(15, n - 2) = "Budget"
vR(15, n - 1) = "Installemnt"
vR(15, n) = "Deviation"
vR(16, n - 2) = vDB(i + 9, 1) 'ap10
vR(16, n - 1) = vDB(i + 10, 1) 'ap11
vR(16, n) = vDB(i + 11, 1) 'ap12
vR(17, n - 2) = vDB(i + 9, 2) 'aq10
vR(17, n - 1) = vDB(i + 10, 2) 'aq11
vR(17, n) = vDB(i + 11, 2) 'aq12
vR(18, n - 2) = vDB(i + 9, 3) 'ar10
vR(18, n - 1) = vDB(i + 10, 3) 'ar11
vR(18, n) = vDB(i + 11, 3) 'ar12
vR(19, n - 2) = vDB(i + 9, 4) 'as10
vR(19, n - 1) = vDB(i + 10, 4) 'as11
vR(19, n) = vDB(i + 11, 4) 'as12
'Column u,v
vR(20, n - 2) = vDB(i + 3, 8) 'aw4
vR(21, n - 2) = vDB(i + 2, 8) 'aw3
End If
Next i
With Ark4
.Range("b4").Resize(n, 21) = WorksheetFunction.Transpose(vR)
End With
End Sub
It is assumed that the data in the data sheet is repeated as shown in the following figure.
I am trying to use the Application.Index function with an variant 2D Array which contains some elements having >255 characters of text. This results in Variant/Integer Type Type Mismatch error. I am also unable to use Application.Transpose because of hitting this >255 characters limit.
Has anyone made any Custom INDEX UDFunction that can handle >255 characters of text to overcome this limit?
e.g.
The snippet code looks like this:
........
........
For j = 1 to NoOfSlides
A = (j - 1) * (nRw * 2) + 1
B = IIf(A >= UBound(Arr, 1), UBound(Arr, 1), (A + (nRw * 2)) - 1)
If B > UBound(Arr, 1) Then B = UBound(Arr, 1)
ab_Rng = Evaluate("row(" & A & ":" & B & ")")
TmpArr(j) = Application.Index(Arr, ab_Rng, Array(1, 2)) ' Type Mismatch Error
With oPres
Set oSlide = .slides("Slide0_ABC").Duplicate
oSlide.moveto toPos:=.slides.Count
With oSlide
....
End With
If getDimensions(TmpArr(j))<2 Then
TmpArr(j) = Application.Transpose(TransposeDim(TmpArr(j)) ) ' Error
End If
For y = LBound(TmpArr(j), 1) To UBound(TmpArr(j), 1)
.....
Next y
End With
Next j
........
........
Function getDimensions(var As Variant) As Long
On Error GoTo Err
Dim i As Long
Dim tmp As Long
i = 0
Do While True
i = i + 1
tmp = UBound(var, i)
Loop
Err:
getDimensions = i - 1
On Error GoTo 0
Err.Clear
End Function
Function TransposeDim(v As Variant) As Variant
' Convert 1D Array to 2D Array (1 -Based)
Dim x As Long, y As Long, Xupper As Long, Yupper As Long
Dim tempArray As Variant
on error resume next
Xupper = UBound(v, 2)
if err.number <>0 then
Redim Preserve v(1 to ubound(v), 1 to 1)
Xupper = UBound(v, 2)
endif
on error goto 0
Yupper = UBound(v, 1)
ReDim tempArray(1 To Xupper, 1 To Yupper)
For x = 1 To Xupper
For y = 1 To Yupper
tempArray(x, y) = v(y, x)
Next y
Next x
TransposeDim = tempArray
End Function
Edit:
Here is a Sample.xlsm file and a Sample PPT Template for anyone's perusal.
Dim a(1 To 2, 1 To 2) As String
Dim o As String
a(1, 2) = "testing " & String(255, "x")
o = Application.Index(a, 1, 2)
Debug.Print Len(o)
To support my comment, you are not using index correctly. I think you'll need to use your Array(1, 2)(0) and Array(1, 2)(1)
Interestingly, though strange enough, i found that as the Arr is defined as a Variant and pulls in Range data .e.g.
Arr = Sheet1.Range("A3:B8").Formula ' a Variant/Variant array
INDEX, TRANSPOSE, MATCH etc., will not work and result in Type MisMatch Error on hitting the >255 Characters limit. I think it internally uses an Integer index and therefore maintains a 255 character limit.
However, if i defined the Array Arr as a String:
' Define Arr as a String
ReDim Arr(1 To UBound(VarRng.Formula, 1), 1 To UBound(VarRng.Formula, 2)) As String
For x = LBound(VarRng.Formula, 1) To UBound(VarRng.Formula, 1)
For y = LBound(VarRng.Formula, 2) To UBound(VarRng.Formula, 2)
Arr(x, y) = CStr(VarRng.Formula(x, y))
Next y
Next x
'...then INDEX, TRANSPOSE, MATCH etc., will work properly, even though there are >255 Characters in the Array.
' Define Arr as a String
ReDim Arr(1 To UBound(VarRng.Formula, 1), 1 To UBound(VarRng.Formula, 2)) As String
For x = LBound(VarRng.Formula, 1) To UBound(VarRng.Formula, 1)
For y = LBound(VarRng.Formula, 2) To UBound(VarRng.Formula, 2)
Arr(x, y) = CStr(VarRng.Formula(x, y))
Next y
Next x
`Arr` is now a Variant/String
'....
'....
For j = 1 to NoOfSlides
A = (j - 1) * (nRw * 2) + 1
B = IIf(A >= UBound(Arr, 1), UBound(Arr, 1), (A + (nRw * 2)) - 1)
If B > UBound(Arr, 1) Then B = UBound(Arr, 1)
ab_Rng = Evaluate("row(" & A & ":" & B & ")")
TmpArr(j) = Application.Index(Arr, ab_Rng, Array(1, 2))
'....
Next j
Sample.xlsm and PPT Sample Template.pptx
Hope this helps.
I have written a code which solves a system of linear equations serval times in a row during a Monte Carlo simulation.
For each run the input is slightly changed and the solution must be calculated every time again. The purpose of this is to obtain the probability distribution function of the results (the solutions of the linear system).
So, my question is:
Is there a way to solve the system of linear equations only once and save the generic solution so that for every Monte Carlo run the solutions can be calculated directly?
This would be very time saving as for a proper simulation I need at least 20k runs and even for small systems of three unknowns this takes a long time. My code solves this linear equations every time new as in its original version the number of variables and therefore the number of input quantities should be closable and thus the generic solutions are unknow.
Here is my Gaussian elimination algorithm.
Function gaussian_elimination(w As Variant, mm As Variant, R As Variant, rb As Variant, n_iso As Integer) As Variant()
'initializing running indexes
Dim i As Integer
Dim j As Integer
Dim h As Integer
Dim n As Integer
n = n_iso
'runing variables for Gauss elimination
Dim ip As Integer
Dim q As Integer
Dim p As Integer
Dim z As Double
Dim temp1(1, 1) As Variant
Dim temp2(1, 1) As Variant
Dim sum As Variant
'initializing b vector
Dim b() As Variant
ReDim b(1 To n - 1, 0 To 1)
'initializing k vector
Dim k() As Variant
ReDim k(1 To n - 1, 0 To 1)
'initializing A matrix
Dim a() As Variant
ReDim a(1 To n - 1, 1 To n - 1)
'initializing X matrix
Dim x() As Variant
ReDim x(1 To n - 1, 1 To n)
' calculating b vector
For i = 1 To (n - 1) Step 1
b(i, 0) = mm(1, 0) / (w(i + n - 1, 0) * (rb(i, 0) - R(i * n, 0))) - mm(1, 0) / (w(i, 0) * (R(i, 0) - rb(i, 0)))
Next i
'calculating A matrix
For i = 1 To (n - 1) Step 1
For j = 1 To (n - 1) Step 1
a(i, j) = mm(j + 1, 0) * ((R(j + i * (n - 1), 0) / (w(i + n - 1, 0) * (rb(i, 0) - R(i * n, 0)))) - (R(j, 0) / (w(i, 0) * (R(i, 0) - rb(i, 0)))))
Next j
Next i
'using on board solving routine
Dim A_Inv As Variant
Dim k_vec As Variant
Dim b_dummy As Variant
'filling X matrix
For i = 1 To n - 1 Step 1
For j = 1 To n Step 1
If j = (n) Then
x(i, j) = b(i, 0)
Else: x(i, j) = a(i, j)
End If
Next j
Next i
'Gaussian elimination
For i = 1 To (n - 2) Step 1
For j = i + 1 To (n - 1) Step 1
If (Abs(x(j, i)) > Abs(x(i, i))) Then
For h = 1 To n
temp1(1, 1) = x(i, h)
temp2(1, 1) = x(j, h)
x(i, h) = temp2(1, 1)
x(j, h) = temp1(1, 1)
Next h
End If
Next
For p = i + 1 To n - 1
z = x(p, i) / x(i, i)
For q = i + 1 To n
x(p, q) = x(p, q) - z * x(i, q)
Next q
x(p, i) = 0
Next p
Next i
'calculatiing k factors backwards
If Abs(x(UBound(x, 1), UBound(x, 2) - 1)) <= 0 Then
MsgBox "Equation system can not be solved! Solving for k factors faild", vbExclamation, "Warning!"
Exit Function
End If
k((UBound(x, 1)), 0) = x((UBound(x, 1)), UBound(x, 2)) / x((UBound(x, 1)), (UBound(x, 2) - 1))
For i = ((UBound(x, 1) - 1)) To (LBound(x, 1)) Step -1
sum = x(i, UBound(x, 2))
For j = i + 1 To (UBound(x, 2) - 1) Step 1
sum = sum - x(i, j) * k(j, 0)
Next j
k(i, 0) = sum / x(i, i)
Next i
For i = 1 To n - 1
k(i, 0) = (-1) * k(i, 0)
Next i
gaussian_elimination = k
End Function
I am working on a schedule determining who is going to cook and who is doing dishes for a trip with some friends.
I have the names for the participants listed in column "A" and using CountIf to see how many times the specific person appears on the schedule to make it fair for everyone. The code picks 2 random persons for cooking and 2 for dishes making sure they are not the same. Then putting those names into the schedule I have defined in the worksheet.
My current code looks like this and is working so far as intended.
Private Sub cookplan()
last_row = Range("A1").End(xlDown).Row
Dim awesome()
Dim index1 As Integer
Dim index2 As Integer
Dim cook1 As String
Dim cook2 As String
Dim dish1 As String
Dim dish2 As String
ReDim awesome(last_row - 1, 0)
For i = 0 To last_row - 1
awesome(i, 0) = Range("A" & i + 1)
Next
For i = 1 To 5
index1 = Int((last_row - 1 - 0 + 1) * Rnd + 0)
cook1 = awesome(index1, 0)
Cells(i * 2, 6).Value = cook1
Do
index2 = Int((last_row - 1 - 0 + 1) * Rnd + 0)
cook2 = awesome(index2, 0)
Cells(i * 2, 7).Value = cook2
Loop While cook2 = cook1
Do
index1 = Int((last_row - 1 - 0 + 1) * Rnd + 0)
dish1 = awesome(index1, 0)
Loop While dish1 = cook1 Or dish1 = cook2
Do
index2 = Int((last_row - 1 - 0 + 1) * Rnd + 0)
dish2 = awesome(index2, 0)
Loop While dish2 = cook1 Or dish2 = cook2 Or dish2 = dish1
Cells(i * 2, 8).Value = dish1
Cells(i * 2, 9).Value = dish2
Next
End Sub
Is there a way to make a name appear a maximum and minimum number of times? As it is now, 2 or 3 times seems to be a fair number when I run the code and look at the CountIf results.
UPDATE
I have now gotten the code to work as intended. Each person needs at least one cooking and dishes duty, so the coding looks like this now. I know it is not that pretty, but it gets the job done :)
Private Sub cookplan()
last_row = Range("A1").End(xlDown).Row
Dim awesome()
Dim index As Integer
Dim cook1 As String
Dim cook2 As String
Dim dish1 As String
Dim dish2 As String
Dim counter1 As Integer
Dim counter2 As Integer
ReDim awesome(last_row - 2, 0)
For i = 0 To last_row - 2
awesome(i, 0) = Range("A" & i + 2)
Next
Do
For i = 1 To 5
Do
index = Int((last_row - 2 - 0 + 1) * Rnd + 0)
cook1 = awesome(index, 0)
Cells(i * 2, 6).Value = cook1
Loop While Cells(index + 2, 2) > 2 Or Cells(index + 2, 3) > 2
Do
index = Int((last_row - 2 - 0 + 1) * Rnd + 0)
cook2 = awesome(index, 0)
Cells(i * 2, 7).Value = cook2
Loop While Cells(index + 2, 2) > 2 Or Cells(index + 2, 3) > 2 Or cook2 = cook1
Do
index = Int((last_row - 2 - 0 + 1) * Rnd + 0)
dish1 = awesome(index, 0)
Cells(i * 2, 8).Value = dish1
Loop While Cells(index + 2, 2) > 2 Or Cells(index + 2, 3) > 2 Or dish1 = cook1 Or dish1 = cook2
Do
index = Int((last_row - 2 - 0 + 1) * Rnd + 0)
dish2 = awesome(index, 0)
Cells(i * 2, 9).Value = dish2
Loop While Cells(index + 2, 2) > 2 Or Cells(index + 2, 3) > 2 Or dish2 = cook1 Or dish2 = cook2 Or dish2 = dish1
Next
counter1 = 0
counter2 = 0
For i = 2 To last_row
If Cells(i, 2).Value = 0 Then
counter1 = counter1 + 1
End If
If Cells(i, 3).Value = 0 Then
counter2 = counter2 + 1
End If
Next
Loop While counter1 > 0 Or counter2 > 0
End Sub
You could put your random generation in a separte function, that checks the worksheet, if the selected name has already been used twice. If false, it returns the name. If true, the function calls itself (hence generates a new name), until a name is found, which fits your criteria.
Update Please note, that this is some kind of pseudo-code, which is not intended to work
In your Sub cookplan, you add the name of the Function everytime you need a new name
cook1 = GetName()
After the End Sub you insert a new Funktion called GetName (or whatever you want)
Function GetName() As String
'Determine your name here
If CountForDeterminedName > 2 Then
'Call Function Again to find another Name
GetName = GetName()
Else
GetName = DeterminedName
End If
End Function