I'm running the code below and it takes around 8 hours to complete. It chooses 20 projects (out of 38) by maximizing the utility of the projects while keeping the budget constraint. There is also a constraint on the min/max number of projects of ClassA, ClassB and ClassA and ClassB combined.
The code works fine, however it takes a long time to complete. Do you know how to optimize this code to make it run faster (if possible)?
'''
Sub CalculateOptions()
Dim InputProjects(1 To 38, 4) As Single
Dim TopChoices(1 To 5, 1 To 22) As Single
Dim CurrentChoice(1 To 22) As Single
TotalHorInArray = 22
TotalVertInArray = 5
MinimalProjectsClassA = 9
MaximalProjectsClassA = 14
MinimalProjectsClassB = 5
MaximalProjectsClassB = 9
MinimalProjectsClassAandClassB = 15
MaximalProjectsClassAandClassB = 19
Budget = 49
NumberOfProjects = 38
'Read input
For x = 1 To NumberOfProjects
For y = 1 To 4
InputProjects(x, y) = Cells(2 + x, 4 + y)
Next
Next
For a = 1 To NumberOfProjects
For b = a + 1 To NumberOfProjects
For c = b + 1 To NumberOfProjects
For d = c + 1 To NumberOfProjects
For e = d + 1 To NumberOfProjects
For f = e + 1 To NumberOfProjects
For g = f + 1 To NumberOfProjects
For h = g + 1 To NumberOfProjects
For i = h + 1 To NumberOfProjects
For j = i + 1 To NumberOfProjects
For k = j + 1 To NumberOfProjects
For l = k + 1 To NumberOfProjects
For m = l + 1 To NumberOfProjects
For n = m + 1 To NumberOfProjects
For o = n + 1 To NumberOfProjects
For p = o + 1 To NumberOfProjects
For q = p + 1 To NumberOfProjects
For r = q + 1 To NumberOfProjects
For s = r + 1 To NumberOfProjects
For t = s + 1 To NumberOfProjects
' Utility
UtilityChoice = InputProjects(a, 1) + _
InputProjects(b, 1) + _
InputProjects(c, 1) + _
InputProjects(d, 1) + _
InputProjects(e, 1) + _
InputProjects(f, 1) + _
InputProjects(g, 1) + _
InputProjects(h, 1) + _
InputProjects(i, 1) + _
InputProjects(j, 1) + _
InputProjects(k, 1) + _
InputProjects(l, 1) + _
InputProjects(m, 1) + _
InputProjects(n, 1) + _
InputProjects(o, 1) + _
InputProjects(p, 1) + _
InputProjects(q, 1) + _
InputProjects(r, 1) + _
InputProjects(s, 1) + _
InputProjects(t, 1)
' Check if utility constraint is met (only want to show the top 5 combinations in the output)
If UtilityChoice > max5 Then
' Budget
budgetChoice = InputProjects(a, 3) _
+ InputProjects(b, 3) _
+ InputProjects(c, 3) _
+ InputProjects(d, 3) _
+ InputProjects(e, 3) _
+ InputProjects(f, 3) _
+ InputProjects(g, 3) _
+ InputProjects(h, 3) _
+ InputProjects(i, 3) _
+ InputProjects(j, 3) _
+ InputProjects(k, 3) _
+ InputProjects(l, 3) _
+ InputProjects(m, 3) _
+ InputProjects(n, 3) _
+ InputProjects(o, 3) _
+ InputProjects(p, 3) _
+ InputProjects(q, 3) _
+ InputProjects(r, 3) _
+ InputProjects(s, 3) _
+ InputProjects(t, 3)
' Check if budget constraint is met
If budgetChoice <= Budget Then
' Check number of projects per Class
ClassOfProject = InputProjects(a, 4) + _
InputProjects(b, 4) + _
InputProjects(c, 4) + _
InputProjects(d, 4) + _
InputProjects(e, 4) + _
InputProjects(f, 4) + _
InputProjects(g, 4) + _
InputProjects(h, 4) + _
InputProjects(i, 4) + _
InputProjects(j, 4) + _
InputProjects(k, 4) + _
InputProjects(l, 4) + _
InputProjects(m, 4) + _
InputProjects(n, 4) + _
InputProjects(o, 4) + _
InputProjects(p, 4) + _
InputProjects(q, 4) + _
InputProjects(r, 4) + _
InputProjects(s, 4) + _
InputProjects(t, 4) + 10
ProjectsClassA = Right(ClassOfProject, 2) - 10
ProjectsClassB = Round(ClassOfProject / 100, 0)
ProjectsClassAorB = ProjectsClassA + ProjectsClassB
' Check if minumum and maximum constraint is satisfied for total projects of class A and B
If ProjectsClassA >= MinimalProjectsClassA And ProjectsClassA <= MaximalProjectsClassA _
And ProjectsClassB >= MinimalProjectsClassB And ProjectsClassB <= MaximalProjectsClassB And _
ProjectsClassAorB >= MinimalProjectsClassAandClassB And ProjectsClassAorB <= MaximalProjectsClassAandClassB Then
' Project specifics
CurrentChoice(1) = InputProjects(a, 2)
CurrentChoice(2) = InputProjects(b, 2)
CurrentChoice(3) = InputProjects(c, 2)
CurrentChoice(4) = InputProjects(d, 2)
CurrentChoice(5) = InputProjects(e, 2)
CurrentChoice(6) = InputProjects(f, 2)
CurrentChoice(7) = InputProjects(g, 2)
CurrentChoice(8) = InputProjects(h, 2)
CurrentChoice(9) = InputProjects(i, 2)
CurrentChoice(10) = InputProjects(j, 2)
CurrentChoice(11) = InputProjects(k, 2)
CurrentChoice(12) = InputProjects(l, 2)
CurrentChoice(13) = InputProjects(m, 2)
CurrentChoice(14) = InputProjects(n, 2)
CurrentChoice(15) = InputProjects(o, 2)
CurrentChoice(16) = InputProjects(p, 2)
CurrentChoice(17) = InputProjects(q, 2)
CurrentChoice(18) = InputProjects(r, 2)
CurrentChoice(19) = InputProjects(s, 2)
CurrentChoice(20) = InputProjects(t, 2)
CurrentChoice(21) = UtilityChoice
CurrentChoice(22) = budgetChoice
' Read in project specifics if utility is in the top 5 (and constraints above are met)
If UtilityChoice > max1 Then
max5 = max4
max4 = max3
max3 = max2
max2 = max1
max1 = UtilityChoice
For Z = 1 To TotalHorInArray
TopChoices(5, Z) = TopChoices(4, Z)
TopChoices(4, Z) = TopChoices(3, Z)
TopChoices(3, Z) = TopChoices(2, Z)
TopChoices(2, Z) = TopChoices(1, Z)
TopChoices(1, Z) = CurrentChoice(Z)
Next
ElseIf UtilityChoice > max2 Then
max5 = max4
max4 = max3
max3 = max2
max2 = UtilityChoice
For Z = 1 To TotalHorInArray
TopChoices(5, Z) = TopChoices(4, Z)
TopChoices(4, Z) = TopChoices(3, Z)
TopChoices(3, Z) = TopChoices(2, Z)
TopChoices(2, Z) = CurrentChoice(Z)
Next
ElseIf UtilityChoice > max3 Then
max5 = max4
max4 = max3
max3 = UtilityChoice
For Z = 1 To TotalHorInArray
TopChoices(5, Z) = TopChoices(4, Z)
TopChoices(4, Z) = TopChoices(3, Z)
TopChoices(3, Z) = CurrentChoice(Z)
Next
ElseIf UtilityChoice > max4 Then
max5 = max4
max4 = UtilityChoice
For Z = 1 To TotalHorInArray
TopChoices(5, Z) = TopChoices(4, Z)
TopChoices(4, Z) = CurrentChoice(Z)
Next
ElseIf UtilityChoice > max5 Then
max5 = UtilityChoice
For Z = 1 To TotalHorInArray
TopChoices(5, Z) = CurrentChoice(Z)
Next
End If
End If
End If
End If
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
Next
' Write output to excel
For x = 1 To TotalVertInArray
For y = 1 To TotalHorInArray
Range("OutputCalculation").Offset(x, y) = TopChoices(x, y)
Next
Next
Range("A1").Select
End Sub
'''
Thanks,
Walther
Related
I'm using DLookup to search for a field in a table. It runs correctly, but is slow. Is there anything I can do to speed it up?
Here's my existing code:
Me(k1) = Dlookup("[KLant]", "[Planning_tbl02]", "[Plek#]=" & p & " AND [datum]='" & Me(k4) & "'" & " AND [bezet_ochtend]='" & "bezet" & "'")
Add indexes in the table on the fields you filter on.
thanks for your replys.
It's a form with +/- 780 unbound textfields which should be filled with data from a table.
I build a program for a little camping and this form is a sort of planning for the available places per day. So they have 30 places and they want to see 2 weeks, so a lot of fields, because they aslo want the day split in morning and and afternoon.
I know, it's maybe not the correct way to progam, but my knowledge is not bigger at the moment :-(
So, if somebody has a good suggestion, I will really appreciate that.
See below for the complete code, it's a loop in a loop.
Private Sub Form_Load()
For p = 1 To 30
k2 = 1
k3 = 1
r1 = r1 - 49
g = g + 52
b = b - 127
If r1 < 0 Then r1 = 255
If g < 0 Then g = 200
If b < 0 Then b = 160
If r1 > 255 Then r1 = 31
If g > 255 Then g = 100
If b > 255 Then b = 56
For k2 = 1 To 26
k1 = "pl" & p & "_" & k2
k4 = "calday" & k3
If r1 < 0 Then r1 = 255
If g < 0 Then g = 200
If b < 0 Then b = 160
If r1 > 255 Then r1 = 31
If g > 255 Then g = 100
If b > 255 Then b = 56
If k2 Mod 2 = 1 Then
Dim strCriteria As String, strQuery As String
strCriteria = _
BuildCriteria("[Plek#]", dbLong, p) & " And " & _
BuildCriteria("[datum]", dbDate, Me(k4)) & " And " & _
BuildCriteria("[bezet_ochtend]", dbText, """bezet""")
strQuery = "SELECT [KLant] FROM [Planning_tbl02] WHERE " & strCriteria
With CurrentDb.OpenRecordset(strQuery, dbOpenForwardOnly)
If Not .EOF Then
Me(k1) = ![klant]
Else
Me(k1) = Null
End If
.Close
End With
If k2 = 1 Then
If Me(k1).Value <> "" Then
Me(k1).BackColor = RGB(r1, g, b)
End If
End If
If k2 - 1 > 0 Then
If Me(k1).Value <> "" And IsNull(Me("pl" & p & "_" & (k2 - 1)).Value) Then
Me(k1).BackColor = RGB(r1, g, b)
End If
End If
If k2 - 1 > 0 Then
If Me(k1).Value <> "" And Me("pl" & p & "_" & k2) = Me("pl" & p & "_" & (k2 - 1))Then
Me(k1).BackColor = RGB(r1, g, b)
End If
End If
If k2 - 1 > 0 Then
If Me("pl" & p & "_" & k2) <> Me("pl" & p & "_" & (k2 - 1)) Then
r1 = r1 - 49
g = g + 52
b = b - 127
Me(k1).BackColor = RGB(r1, g, b)
End If
End If
End If
If k2 Mod 2 <> 1 Then
strCriteria = _
BuildCriteria("[Plek#]", dbLong, p) & " And " & _
BuildCriteria("[datum]", dbDate, Me(k4)) & " And " & _
BuildCriteria("[bezet_ochtend]", dbText, """bezet""")
strQuery = "SELECT [KLant] FROM [Planning_tbl02] WHERE " & strCriteria
With CurrentDb.OpenRecordset(strQuery, dbOpenForwardOnly)
If Not .EOF Then
Me(k1) = ![klant]
Else
Me(k1) = Null
End If
.Close
End With
If Me(k1).Value <> "" And IsNull(Me("pl" & p & "_" & (k2 - 1)).Value) Then
Me(k1).BackColor = RGB(r1, g, b)
End If
If Me(k1).Value <> "" And Me("pl" & p & "_" & k2) = Me("pl" & p & "_" & (k2 - 1))Then
Me(k1).BackColor = RGB(r1, g, b)
End If
If k2 - 1 > 0 Then
If Me(k1).Value <> "" And Me("pl" & p & "_" & k2) <> Me("pl" & p & "_" & (k2 - 1)) Then
Me(k1).BackColor = RGB(r1, g, b)
End If
End If
If k2 - 1 > 0 Then
If Me("pl" & p & "_" & k2) <> Me("pl" & p & "_" & (k2 - 1)) Then
r1 = r1 - 49
g = g + 52
b = b - 127
If r1 < 0 Then r1 = 255
If g < 0 Then g = 200
If b < 0 Then b = 160
Me(k1).BackColor = RGB(r1, g, b)
End If
End If
End If
If k2 Mod 2 <> 1 Then
k3 = k3 + 1
End If
Next
Next
End Sub
You could write your own lookup code that opens a recordset and finds the desired value, for example:
Dim strCriteria As String, strQuery As String
strCriteria = _
BuildCriteria("[Plek#]", dbLong, p) & " And " & _
BuildCriteria("[datum]", dbDate, Me(k4)) & " And " & _
BuildCriteria("[bezet_ochtend]", dbText, """bezet""")
strQuery = "SELECT [KLant] FROM [Planning_tbl02] WHERE " & strCriteria
With CurrentDb.OpenRecordset(strQuery, dbOpenForwardOnly)
If Not .EOF Then
Me(k1) = ![KLant]
Else
Me(k1) = Null
End If
.Close
End With
Added:
After reviewing your code, I found that the statements for odd and even values of k2 doesn't differ much, so I was able to simplify the code a little. Also, I found that k4 changes only for odd values of k2 which halves the number of database searches. This means of course, that there will be no difference in the afternoon. Finally, as promised in my comment, I reduced the number of recordsets to 30 and implemented searches with FindFirst for the dates. Here's my result:
Private Sub Form_Load()
Dim p As Integer, k2 As Integer
Dim k1 As String, k1_prev As String, k4 As String
Dim r1 As Integer, g As Integer, b As Integer
Dim strCriteria As String, strQuery As String
For p = 1 To 30
If r1 < 49 Then r1 = 255 Else r1 = r1 - 49
If g > 203 Then g = 100 Else g = g + 52
If b < 127 Then b = 160 Else b = b - 127
strQuery = "SELECT [KLant], [datum] FROM [Planning_tbl02] WHERE " & _
BuildCriteria("[Plek#]", dbLong, p) & " And " & _
BuildCriteria("[bezet_ochtend]", dbText, """bezet""")
With CurrentDb.OpenRecordset(strQuery, dbOpenDynaset)
For k2 = 1 To 26
k1_prev = k1
k1 = "pl" & p & "_" & k2
If k2 Mod 2 = 1 Then
k4 = "calday" & (k2 + 1) \ 2
.FindFirst BuildCriteria("[datum]", dbDate, Me(k4))
If .NoMatch Then Me(k1) = Null Else Me(k1) = ![klant]
Else
Me(k1) = Me(k1_prev)
End If
If Not IsNull(Me(k1)) Then
If k2 = 1 Then
Me(k1).BackColor = RGB(r1, g, b)
Else
If Me(k1) <> Me(k1_prev) Then 'next color
If r1 < 49 Then r1 = 255 Else r1 = r1 - 49
If g > 203 Then g = 100 Else g = g + 52
If b < 127 Then b = 160 Else b = b - 127
End If
Me(k1).BackColor = RGB(r1, g, b)
End If
End If
Next
.Close
End With
Next
End Sub
I have a function that maps data from one sheet (where it has been copied) to another which is then used for further analysis. When I run the code with screen updating on it always works fine. When I turn screen updating off the code gets stuck in an infinite loop in the last part of the sub (highlighted in bold - it is the inner most loop of the final section of code). If you then debug the code and re-start it continues normally and finished the code. If left it will never end, but next time will work fine:
Sub simsMap()
Dim simsCol As String
Dim mapCol As String
range("A5:OP253").ClearContents
range("S1:OP1").ClearContents
range("S4:OP4").ClearContents
simsCol = range("A1")
For x = 2 To 250
If Worksheets("simsData").range(simsCol & x) <> "" Then range("A" & x + 3).Value = Worksheets("simsData").range(simsCol & x)
Next x
simsCol = range("B1")
For x = 2 To 250
If range("A" & x + 3) <> "" Then
If Worksheets("simsData").range(simsCol & x) = range("B2") Or Worksheets("simsData").range(simsCol & x) = range("B3") Then
range(simsCol & x + 3) = "Y"
Else
range(simsCol & x + 3) = "N"
End If
End If
Next x
Dim simsArray As Variant
Dim mapArray As Variant
simsArray = Array("C1", "D1", "G1")
mapArray = Array("C", "D", "G")
For y = 0 To UBound(simsArray)
simsCol = range(simsArray(y))
mapCol = mapArray(y)
For x = 2 To 250
If range("A" & x + 3) <> "" Then
If Worksheets("simsData").range(simsCol & x) = "Y" Then
range(mapCol & x + 3) = "Y"
Else
range(mapCol & x + 3) = "N"
End If
End If
Next x
Next y
simsArray = Array("E1", "F1", "H1", "I1", "J1", "K1", "L1", "M1", "N1", "O1", "P1", "Q1")
mapArray = Array("E", "F", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q")
For y = 0 To UBound(simsArray)
simsCol = range(simsArray(y))
mapCol = mapArray(y)
For x = 2 To 250
If range("A" & x + 3) <> "" Then
range(mapCol & x + 3) = Worksheets("simsData").range(simsCol & x)
End If
Next x
Next y
Dim realColumn As String
Dim valueColumn As String
Dim columnNumber As Long
Dim realCell As String
Dim valueCell As String
Dim subjectJump As Integer
realColumn = "S"
subjectJump = 8 - Worksheets("menu").range("F17")
For y = 1 To 48
If Worksheets("menu").range("F19") = "Y" Then
valueColumn = range(realColumn & 1)
realCell = realColumn & 1
realColumn = Split(Cells(1, range(realCell).Column + 1).Address, "$")(1)
range(realColumn & 1) = valueColumn
For x = 1 To Worksheets("menu").range("F17")
valueCell = range(realColumn & 1) & 1
If range(realColumn & 1) <> "" Then valueColumn = Split(Cells(1, range(valueCell).Column + 1).Address, "$")(1)
realCell = realColumn & 1
realColumn = Split(Cells(1, range(realCell).Column + 1).Address, "$")(1)
range(realColumn & 1) = valueColumn
Next x
Else
If range(realColumn & 1) = "" Then
realCell = realColumn & 1
realColumn = Split(Cells(1, range(realCell).Column + 8).Address, "$")(1)
Else
For x = 1 To Worksheets("menu").range("F17")
valueCell = range(realColumn & 1) & 1
valueColumn = Split(Cells(1, range(valueCell).Column + 1).Address, "$")(1)
realCell = realColumn & 1
realColumn = Split(Cells(1, range(realCell).Column + 1).Address, "$")(1)
range(realColumn & 1) = valueColumn
Next x
realCell = realColumn & 1
realColumn = Split(Cells(1, range(realCell).Column + subjectJump).Address, "$")(1)
End If
End If
Next y
realColumn = "S"
For y = 1 To 384
simsCol = range(realColumn & 1)
mapCol = realColumn
If range(mapCol & 1) <> "" Then
If range("A" & 4) <> "" Then
range(mapCol & 4) = Worksheets("simsData").range(simsCol & 1)
End If
End If
realColumn = Split(Cells(1, range(realColumn & 1).Column + 1).Address, "$")(1)
Next y
realColumn = "S"
For y = 1 To 384
simsCol = range(realColumn & 1)
mapCol = realColumn
If range(mapCol & 1) <> "" Then
For x = 2 To 250
**If range("A" & x + 3) <> "" Then
range(mapCol & x + 3) = Left(Worksheets("simsData").range(simsCol & x), 1)
End If**
Next x
End If
realColumn = Split(Cells(1, range(realColumn & 1).Column + 1).Address, "$")(1)
If y = 384 Then loopCheck = False
Next y
For x = 5 To 253
If range("A" & x) <> "" Then studentNumber = x
Next x
End Sub
I need a looping structure that checks a range of cells, then if the cell and a cell that is in the range equal each other then the font should turn red. My problem is that my do until loop won't get entered. This is what I have right now.
`
Dim finalrow As Long
finalrow = Worksheets("Redundancy").Cells(Worksheets("Redundancy").Rows.Count, "D").End(xlUp).Row
Dim z As Long
Dim w As Long
Dim r As Long
w = 2
r = 0
For z = 2 To finalrow
If Range("L" & z) = Range("L" & z + 1) & Range("J" & z) <> Range("J" & z + 1) Then
Do Until Range("L" & z) = Range("L" & z + 1) & Range("J" & z) <> Range("J" & z + 1)
If Cells(w, 4) = Cells(z + 1, 4 + r) Then
Cells(w, 1).Font.ColorIndex = 3
Cells(z + 1, 1).Font.ColorIndex = 3
If r = 4 Then
w = w + 1
End If
End If
r = r + 1
Loop
End If
Next z
`
I changed it to this, but it exits the loop all together right when it is about to enter the do while loop.
`
For z = 2 To finalrow
Do While (Range("L" & z) = Range("L" & z + 1) And Range("J" & z) <> Range("J" & z + 1))
If Cells(w, 4) = Cells(z + 1, 4 + r) Then
Cells(w, 1).Font.ColorIndex = 3
Cells(z + 1, 1).Font.ColorIndex = 3
If r = 4 Then
w = w + 1
End If
End If
r = r + 1
Loop
Next z
`
If you do this;
Range("L" & z) = Range("L" & z + 1) and Range("J" & z) <> Range("J" & z + 1)
you are comparing Range objects. What you instead want to do is to compare the values in those range objects. So use this instead;
Range("L" & z).value = Range("L" & z + 1).value and Range("J" & z).value <> Range("J" & z + 1).value
However when you use the cells(row,column) you don't have this problem.
I am curious though, was it not possible to use conditional formatting instead?
Use the 'and' operator instead of '&'.
I am trying to fill a range with a formula and continue to get a runtime error '1004'. The error occurs at the line I have starred Sheets("Forecast").Range("H125").Formula = formulaTest. The code in my Sub is as follows:
Sub FirmShareFill()
Dim RampUp As Range
Dim RampBas As Range
Dim RampDn As Range
Dim Numbering As Range
Dim Approval As Range
Dim PeakShare As Range
Dim tcount As Byte
Dim bcount As Byte
Dim ubdcount As Byte
Dim yearRange2 As Byte
year = Worksheets("Inputs").Range("B6").Value
cntry = Worksheets("Inputs").Range("B5").Value
bnd = Worksheets("Inputs").Range("B3").Value
typ = Worksheets("Inputs").Range("B2").Value
cat = Worksheets("Inputs").Range("B4").Value
tcount = bnd * cat + bnd
ubdcount = tcount * 2 + 1
yearCount = year * 4 - 1
For ubd = 1 To 3
For t = 1 To typ
For b = 1 To bnd
For c = 1 To cat
For i = 1 To cntry
Set RampUp = Columns(7).Find(What:="Ramp_Up" & i, MatchCase:=True).Offset(0, 1)
Set RampBas = Columns(7).Find(What:="Ramp_Bas" & i, MatchCase:=True).Offset(0, 1)
Set RampDn = Columns(7).Find(What:="Ramp_Dn" & i, MatchCase:=True).Offset(0, 1)
Set Numbering = Sheets("Inputs").Range("B13")
Set Approval = Columns(6).Find(What:="Approval", MatchCase:=True).Offset(i, 2 + ubd)
bcount = c + (cat + 1) * (b - 1)
If t = 1 And b = 1 And ubd = 1 Then
Set PeakShare = Columns(5).Find(What:="Peak Share", MatchCase:=True).Offset(4 + i, c)
ElseIf t = 1 And b > 1 And ubd = 1 Then
Set PeakShare = Columns(5).Find(What:="Peak Share" & c, MatchCase:=True).Offset(4 + i, bcount)
ElseIf t > 1 And b = 1 And ubd = 1 Then
Set PeakShare = Columns(5).Find(What:="Peak Share" & c, MatchCase:=True).Offset(4 + i, c + tcount)
ElseIf t > 1 And b > 1 And ubd = 1 Then
Set PeakShare = Columns(5).Find(What:="Peak Share" & c, MatchCase:=True).Offset(4 + i, tcount + bcount)
ElseIf t = 1 And b = 1 And ubd = 2 Then
Set PeakShare = Columns(5).Find(What:="Peak Share", MatchCase:=True).Offset(4 + i, c + ubdcount)
ElseIf t = 1 And b > 1 And ubd = 1 Then
Set PeakShare = Columns(5).Find(What:="Peak Share" & c, MatchCase:=True).Offset(4 + i, bcount + ubdcount)
ElseIf t > 1 And b = 1 And ubd = 1 Then
Set PeakShare = Columns(5).Find(What:="Peak Share" & c, MatchCase:=True).Offset(4 + i, c + tcount + ubdcount)
ElseIf t > 1 And b > 1 And ubd = 1 Then
Set PeakShare = Columns(5).Find(What:="Peak Share" & c, MatchCase:=True).Offset(4 + i, tcount + bcount + ubdcount)
ElseIf t = 1 And b = 1 And ubd = 3 Then
Set PeakShare = Columns(5).Find(What:="Peak Share", MatchCase:=True).Offset(4 + i, c + 2 * ubdcount)
ElseIf t = 1 And b > 1 And ubd = 3 Then
Set PeakShare = Columns(5).Find(What:="Peak Share" & c, MatchCase:=True).Offset(4 + i, bcount + 2 * ubdcount)
ElseIf t > 1 And b = 1 And ubd = 3 Then
Set PeakShare = Columns(5).Find(What:="Peak Share" & c, MatchCase:=True).Offset(4 + i, c + tcount + 2 * ubdcount)
ElseIf t > 1 And b > 1 And ubd = 3 Then
Set PeakShare = Columns(5).Find(What:="Peak Share" & c, MatchCase:=True).Offset(4 + i, tcount + bcount + 2 * ubdcount)
End If
Dim formulaTest As String
formulaTest = "=IF(" & Numbering.Address(False, False) & "<" & Approval.Address & ","", " & PeakShare.Address & " * " & RampUp.Address & ")"
If ubd = 1 Then
**Sheets("Forecast").Range("H125").Formula = formulaTest**
ActiveCell.Offset(1, 0).Select
ElseIf ubd = 2 Then
Range(ActiveCell, ActiveCell.Offset(0, yearRange2)).Formula = "=IF(" & Numbering.Address(False, False) & " < " & Approval.Offset(1, 0).Address & ","", " & PeakShare.Address & " * " & RampBas.Address & ""
ElseIf ubd = 3 Then
Range(ActiveCell, ActiveCell.Offset(0, yearRange2)).Formula = "=IF(" & Numbering.Address(False, False) & " < " & Approval.Offset(1, 0).Address & ","", " & PeakShare.Address & " * " & RampDn.Address & ""
End If
Next i
ActiveCell.Offset(1, 0).Select
Next c
Next b
Next t
Next ubd
End Sub
I believe the error may have something to do with how I declared the range "numbering" range, but as of yet I have been unable to figure it out. I have used this code on the same sheet many times, the only difference being that I have set a range, numbering, on a different sheet.
This should work:
formulaTest = "=IF(" & Numbering.Address(False, False) & "<" & Approval.Address & ",""""," & PeakShare.Address & "*" & RampUp.Address & ")"
As #Comintern pointed out, you need to use """" to include double empty speech marks in your formula. I also removed the spaces either side of the *
change
IF(" & Numbering.Address(False, False) & "<" & Approval.Address & ","", " & PeakShare.Address & " * " & RampUp.Address & ")"
to
IF(" & Numbering.Address(False, False) & "<" & Approval.Address & ","""", " & PeakShare.Address & " * " & RampUp.Address & ")"
Instead of counting how many " you have, you can use Chr(34) inside " to have a Formula check for ".
In your case, use:
"=IF(" & Numbering.Address(False, False) & "<" & Approval.Address & "," & Chr(34) & ", " & PeakShare.Address & " * " & RampUp.Address & ")"
I am using Vb to take a .txt file, parse it, and check for errors. My code works just fine, however, the code does not go through the entire file. It stops, on average, 20 lines shy of the EOF.
I am using the following
For Each lines As String In System.IO.File.ReadLines(myFile)
from here I parse the line and see if it needs any fixes.
Is there something that I'm missing or something that just cant be avoided.
The files that I'm reading in are about 150,000 KB to 230,000 KB and over 2 million lines.
As requested, the following is my code. Warning, I just started using Vb...
Module Module1
Sub Main()
Dim root As String = "C:\Users\mschramm\Documents\Agco\WindSensor\Data\filestobecleaned\"
Dim datafile As String = root & "ES.txt"
Dim outfile As String = root & "temptry.txt"
Dim output As System.IO.StreamWriter = My.Computer.FileSystem.OpenTextFileWriter(outfile, False)
Dim k As UInteger = 0
Dim fixes As UInteger = 0
Dim time As ULong = 0
Dim count As UInteger = 0
Dim n As UInteger = 0
Dim LineCount As UInteger = 0
Dim TimeStep As ULong = 100
Dim Solar As UInteger = 0
For Each lines As String In System.IO.File.ReadLines(datafile)
LineCount = LineCount + 1
'Console.WriteLine(LineCount)
Dim parsedline As String() = Split(lines, ",")
If IsNumeric(parsedline(0)) = True And UBound(parsedline) = 8 Then
'TimeStep = parsedline(0) - time
Solar = parsedline(1)
time = parsedline(0)
output.WriteLine(lines & " Good Line")
count = count + 1
Else
Dim j As UInteger = 0
Dim ETX As Integer = 0
Dim STX As Integer = 0
Dim datacheck As Boolean = False
Dim fixedline As String = ""
Dim newtime As ULong = 0
For j = 0 To UBound(parsedline)
Dim a As Char = parsedline(j)
If a = (Chr(3)) Then ETX = j
If a = (Chr(2)) Then STX = j
Next
j = 0
If (STX < ETX) And (ETX - STX) = 6 And STX >= 2 Then
If Len(parsedline(STX + 1)) = 8 And Len(parsedline(STX + 2)) = 8 And Len(parsedline(STX + 3)) = 8 Then
Dim g = Len(parsedline(STX - 2))
While (j < g) And datacheck = False
If IsNumeric(parsedline(STX - 2)) Then
If parsedline(STX - 2) - time < 10000 And parsedline(STX - 2) - time > 0 Then
newtime = Right(parsedline(STX - 2), Len(parsedline(STX - 2)))
Solar = parsedline(STX - 1)
'TimeStep = newtime - time
fixedline = newtime & "," & parsedline(STX - 1) & "," & parsedline(STX) & "," & parsedline(STX + 1) & "," & parsedline(STX + 2) & "," & parsedline(STX + 3) & "," & parsedline(STX + 4) & "," & parsedline(STX + 5) & "," & parsedline(STX + 6) & " Fixed Line"
datacheck = True
Else
j = j + 1
parsedline(STX - 2) = Right(parsedline(STX - 2), Len(parsedline(STX - 2)) - 1).ToString
End If
Else
j = j + 1
parsedline(STX - 2) = Right(parsedline(STX - 2), Len(parsedline(STX - 2)) - 1).ToString
End If
End While
End If
End If
If (STX < ETX) And (ETX - STX) = 6 And STX = 0 Then
If Len(parsedline(1)) = 8 And Len(parsedline(2)) = 8 And Len(parsedline(3)) = 8 And Len(parsedline(4)) = 1 And Len(parsedline(5)) = 2 And Len(parsedline(6)) = 3 Then
newtime = time + TimeStep
fixedline = newtime & "," & Solar & "," & parsedline(STX) & "," & parsedline(STX + 1) & "," & parsedline(STX + 2) & "," & parsedline(STX + 3) & "," & parsedline(STX + 4) & "," & parsedline(STX + 5) & "," & parsedline(STX + 6) & " Fixed Line Gave Time and Solar"
datacheck = True
End If
End If
If newtime < time And newtime > 1000 Then
Dim badtime As ULong = newtime
Dim firstdig As ULong = time
Dim loopcount As UInteger = 0
While firstdig > 9
firstdig = firstdig / 10
loopcount = loopcount + 1
End While
firstdig = firstdig * (10 ^ loopcount)
If (firstdig + badtime) > time Then
newtime = firstdig + badtime
If (newtime - (10 ^ loopcount)) > time Then
newtime = newtime - (10 ^ loopcount)
End If
End If
End If
If datacheck = True Then
k = k + 1
If (newtime > 500) Then
output.WriteLine(fixedline)
'count = count + 1
time = newtime
End If
End If
If datacheck = False Then
n = n + 1
If STX >= 0 And ETX > 0 And ETX - STX < 9 Then
Console.WriteLine(LineCount)
'n = n + 1
End If
End If
End If
Next
Console.WriteLine(count & " Good lines")
Console.WriteLine(k & " Lines Corrected")
Console.WriteLine(LineCount & " Total Lines")
Console.WriteLine(n & " Lines were thrown out")
Console.WriteLine(n / LineCount * 100 & "% thrown out")
End Sub
End Module
and here is a sample of the data
Time: 16:52:18.0
Date: 11/6/2014
Time,Sensor1,U,V,W
544161,219,Q,-001.341,+000.947,+000.140,M,00,17
544284,218,Q,-001.207,+001.074,+000.225,M,00,1C
544361,220,Q,-000.935,+000.898,+000.187,M,00,17
544460,220,Q,-001.299,+001.151,-000.009,M,00,17
This is what the last 10 lines look like
Q,+001.681,-003.510,-0356154697,236,Q,+000.826,-002.744,-000.559,M,00,19
Q,+000.474,-002.789,-0356155062,234,Q,+000.400,-002.975,+000.438,M,00,1D
Q,+000.813,-002.934,-0356155297,236,Q,+000.146,-002.129,-000.235,M,00,16
Q,+000.494,-002.234,+0356155497,236,Q,+000.681,-001.996,-000.248,M,00,1F
Q,+000.800,-001.999,-0356155697,236,Q,+001.181,-002.883,-000.795,M,00,1A
356156060,233,Q,+000.400,-002.106,+000.251,M,00,18
356156296,235,Q,+000.888,-001.026,+000.442,M,00,10
356156495,236,Q,+000.570,-001.694,+000.589,M,00,13
356156695,236,Q,+001.495,-002.177,-000.035,M,00,15
356157060,234,Q,+000.770,-003.484,-000.161,M,00,14
for this file, the code makes it to the 6th to last line.
Thanks to mafafu for pointing out the solution.
I never closed the file, so the addition of output.Close() fixed everything.
Once again, thank you mafafu.