Function calculateIO(ByVal reachName As String, ByVal natFlow As Double, ByVal IOTableWorksheet As Worksheet, ByVal weeklyDate As Date) As Double
Dim rowNoReach, rowToNextTable, columnNo, rowNo, startColumn, columnCounter, rowCounter, rowCounter1, dateCounter As Integer
Dim vlookupRange As Range
Dim vlookupResult As Double
Dim currentDay, currentMonth As Integer
Dim differenceCal As Double
Dim ansStorage 'where to store the natural flow value from the IO table that is used to obtain the corresponding IO
Dim IOvalue As Double
differenceCal = 1000000
currentDay = day(weeklyDate)
currentMonth = month(weeklyDate)
'Format the reach name if it is a mainstem reach name.
If (InStr(reachName, "Mainstem") > 0) Then reachName = Trim(Split(reachName, "-")(1))
'Initializes the row pointers
rowNoReach = 0
rowToNextTable = 1
startColumn = 1
'It is assumed that there is no IO until one is found
calculateIO = -1
'Loop through each IO table until there an IO table is not found
Do While (rowToNextTable <> 0)
rowNoReach = rowNoReach + rowToNextTable
rowToNextTable = IOTableWorksheet.Cells(rowNoReach, 14).value
'This will compare the reach name with the IO table name. if they are a match then an IO will be calculated using this IO table.
If (InStr(IOTableWorksheet.Cells(rowNoReach, 2).value, reachName) > 0) Then
If ((currentMonth <= 3) Or (currentMonth >= 11)) Then
columnCounter = 1
For columnCounter = 1 To 21
If ((month(IOTableWorksheet.Cells(rowNoReach + 2, columnCounter)) = currentMonth) And (day(IOTableWorksheet.Cells(rowNoReach + 2, i)) = currentDay)) Then
calculateIO = IOTableWorksheet.Cells(rowNoReach + 3, columnCounter).value
Exit Function
End If
Next columnCounter
'looking through the table
ElseIf ((currentMonth >= 4) Or (currentMonth <= 10)) Then
columnCounter = 1
Do While IsDate(IOTableWorksheet.Cells(rowNoReach + 5, columnCounter))
If ((day(weeklyDate) = day(IOTableWorksheet.Cells(rowNoReach + 5, columnCounter))) And (month(weeklyDate) = month(IOTableWorksheet.Cells(rowNoReach + 5, columnCounter)))) Then
startColumn = columnCounter
End If
columnCounter = columnCounter + 1
Loop
If (natFlow < IOTableWorksheet.Cells(rowNoReach + 6, startColumn)) Then
calculateIO = natFlow
Exit Function
ElseIf (natFlow > IOTableWorksheet.Cells(rowNoReach + 6, startColumn)) Then
rowCounter1 = 0
For rowCounter1 = 0 To IOTableWorksheet.Range(IOTableWorksheet.Cells(rowNoReach + 6, startColumn), IOTableWorksheet.Range(IOTableWorksheet.Cells(rowNoReach + 6, startColumn).End(xlDown))).Rows.Count - 1
If (difference > (natFlow - IOTableWorksheet.Cells(rowNoReach + rowCounter1, startColumn))) Then
If (natFlow - IOTableWorksheet.Cells(rowNoReach + rowCounter1, startColumn)) < 0 Then
calculateIO = IOvalue
Exit Function
End If
difference = natFlow - IOTableWorksheet.Cells(rowNoReach + rowCounter1, startColumn)
IOvalue = IOTableWorksheet.Cells(rowNoReach + rowCounter1, 32)
End If
calculateIO = IOvalue
Exit Function
End If
End If
ElseIf (IOTableWorksheet.Cells(rowNoReach, 2).value = "Minimum Or Established IO") Then
'Initialize row and column pointers
rowNo = rowNoReach + 3
columnNo = 2
'Calculate the row and column number
Do While (InStr(reachName, IOTableWorksheet.Cells(rowNoReach + 2, columnNo).value) = 0 And Not IsEmpty(IOTableWorksheet.Cells(rowNoReach + 2, columnNo).value)): columnNo = columnNo + 1: Loop
Do While (month(IOTableWorksheet.Cells(rowNo, 1).value) <> month(weeklyDate) Or day(IOTableWorksheet.Cells(rowNo, 1).value) <> day(weeklyDate)): rowNo = rowNo + 1: Loop
'Get the IO value from the table if the reach was in the table
If Not IsEmpty(IOTableWorksheet.Cells(rowNo, columnNo).value) Then calculateIO = IOTableWorksheet.Cells(rowNo, columnNo): Exit Function
ElseIf (IOTableWorksheet.Cells(rowNoReach, 2).value = "Single IO Streams") Then
'Initialize row and column pointers
rowNo = rowNoReach + 3
columnNo = 2
'Calculate the column number
Do While InStr(reachName, IOTableWorksheet.Cells(rowNoReach + 2, columnNo).value) = 0 And Not IsEmpty(IOTableWorksheet.Cells(rowNoReach + 2, columnNo).value): columnNo = columnNo + 1: Loop
'Get the IO value from the table if the reach was in the table
If Not IsEmpty(IOTableWorksheet.Cells(rowNo, columnNo).value) Then calculateIO = IOTableWorksheet.Cells(rowNo, columnNo): Exit Function
End If
Loop 'looping through the first do while loop
End Function
no idea why the code keeps on having this compiling error, I have basically looked through by identifying each End If statement with the corresponding If-ElseIF-Else statement and no extra End If should be in here. Also I have properly indented the code.
Related
My problem is that im looping over an 2d array in a function but I can't get the previously saved values.
This is my code:
Dim RowCountTemp As Integer
Dim ColumCountTemp As Integer
Dim MonthArray, ColumnArray
Dim NewTable() As String
Dim NewTableLen As Integer
NewTableLen = 0
MonthArray = Array("Enero", "Febrero", "Marzo", "Abril", "Mayo", "Junio", "Julio", "Agosto", "Septiembre", "Octubre", "Noviembre", "Diciembre")
ColumnArray = Array("A", "B", "C")
For Each MonthTemp In MonthArray
With Worksheets(MonthTemp).ListObjects(MonthTemp)
RowCountTemp = .DataBodyRange.Rows.Count
ColumCountTemp = .DataBodyRange.Columns.Count
For i = 1 To RowCountTemp
Dim RucTemp As String
Dim CantTemp As String
Dim Index As Integer
RucTemp = .Range(i + 1, 1)
CantTemp = .Range(i + 1, 3)
Index = Contains(NewTable, NewTableLen, RucTemp)
If Index > 0 Then
NewTable(Index, 3) = NewTable(Index, 3) + CantTemp
Worksheets("Resumen").Range(ColumnArray(2) & Index + 1) = NewTable(Index, 3)
Else
NewTableLen = NewTableLen + 1
'Added Preserve from comment but it throws subindex out of range for the second value added
ReDim Preserve NewTable(NewTableLen, 3)
NewTable(NewTableLen, 1) = .Range(i + 1, 1)
NewTable(NewTableLen, 2) = .Range(i + 1, 2)
NewTable(NewTableLen, 3) = .Range(i + 1, 3)
Worksheets("Resumen").Range(ColumnArray(0) & NewTableLen + 1) = NewTable(NewTableLen, 1)
Worksheets("Resumen").Range(ColumnArray(1) & NewTableLen + 1) = NewTable(NewTableLen, 2)
Worksheets("Resumen").Range(ColumnArray(2) & NewTableLen + 1) = NewTable(NewTableLen, 3)
End If
Next
End With
Next
And my function
Function Contains(Array2D() As String, Length As Integer, SearchFor As String) As Integer
For i = 1 To Length
Contains = 0
If Array2D(i, 1) = SearchFor Then
Contains = i
Exit For
End If
Next
End Function
For instance, when I read the first sheet, January, I save data correctly and I can see it when evaluate Array2D(i, 1), but for the next sheets, when I evaluate Array2D(i, 1), it gives me empty values for all the index stored in past sheets.
Let's suppose January sheet gets 2 rows with values aaaa and bbbb, so, the code allow me to watch aaaa stored when evaluates bbbb, but in february sheet which has aaaa, bbbb and cccc, when Array2D(i, 1) is evaluated until i = 2 for aaaa, i = 3 for bbbb and i = 4 for cccc, the values are empty "" for aaaa, but for bbbb and cccc, it shows me aaaa and bbbb respectively from february sheet so the values are being saved twice
Edit:
I have realized that every time I redeem the previous ones are deleted and the last one is saved
I added Preserve but it throws me subindex out of range for the second value added
Well, at the end i changed the code a little bit to achieve those results.
Here is
Dim RowCountTemp As Integer
Dim ColumCountTemp As Integer
Dim MonthArray, ColumnArray
Dim NewTable() As String
Dim NewTableLen As Integer
NewTableLen = 0
MonthArray = Array("Enero2020", "Febrero2020", "Marzo2020", "Abril2020", "Mayo2020", "Junio2020", "Julio2020", "Agosto2020", "Septiembre2020", "Octubre2020", "Noviembre2020", "Diciembre2020", "Enero2021", "Febrero2021", "Marzo2021", "Abril2021", "Mayo2021")
ColumnArray = Array("A", "B", "C")
For Each MonthTemp In MonthArray
With Worksheets(MonthTemp).ListObjects(MonthTemp)
RowCountTemp = .DataBodyRange.Rows.Count
ColumCountTemp = .DataBodyRange.Columns.Count
'If MonthTemp = "Abril2021" Or MonthTemp = "Mayo2021" Then
For i = 1 To RowCountTemp
Dim RucTemp As String
Dim CantTemp As String
Dim Index As Integer
RucTemp = .Range(i + 1, 1)
CantTemp = .Range(i + 1, 3)
Index = Contains(NewTable, NewTableLen, RucTemp)
If Index > 0 Then
Worksheets("Resumen").Range(ColumnArray(2) & Index + 1) = Worksheets("Resumen").Range(ColumnArray(2) & Index + 1) + CantTemp
Else
NewTableLen = NewTableLen + 1
ReDim Preserve NewTable(NewTableLen)
NewTable(NewTableLen) = .Range(i + 1, 1)
Worksheets("Resumen").Range(ColumnArray(0) & NewTableLen + 1) = NewTable(NewTableLen)
Worksheets("Resumen").Range(ColumnArray(1) & NewTableLen + 1) = .Range(i + 1, 2)
Worksheets("Resumen").Range(ColumnArray(2) & NewTableLen + 1) = .Range(i + 1, 3)
End If
Next
'End If
End With
Next
Function Contains(Array2D() As String, Length As Integer, SearchFor As String) As Integer
For i = 1 To Length
Contains = 0
If Array2D(i) = SearchFor Then
Contains = i
Exit For
End If
Next
End Function
I have an excel table where there are part codes in a column and for every part code, there are 3-4 subsections (1100-1400) with information which I need to attach to the part code in a column view.
The number of created rows depends on if there is data entered into subsection 1400. 1100-1300 has always information and needs to be converted into a table.
I don't even know from where to start so currently I have no code to show
I added a picture of how the data is represented and what the result should look like:
You could do it like that
Option Explicit
Sub TransformA()
Dim rg As Range
Dim lastRow As Long, lineNo As Long, i As Long, j As Long
Dim shInput As Worksheet, shResult As Worksheet
Dim vDat As Variant, resDat As Variant
Dim subSection As String
' Make sure you run the code with the data in the Activesheet
Set shInput = ActiveSheet
' And you have data which starts in row 4 with the heading in row 3
' otherwise adjust accordingly
lastRow = shInput.Range("A4").End(xlDown).Row
Set rg = shInput.Range("A4:I" & lastRow)
vDat = rg
ReDim resDat(1 To UBound(vDat, 1) * 4, 1 To 4)
lineNo = 1
For j = 1 To UBound(vDat, 1)
For i = 0 To 2
Select Case i
Case 0: subSection = "1100"
Case 1: subSection = "1200"
Case 2: subSection = "1300"
End Select
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
Next
i = 3
subSection = "1400"
If Len(vDat(j, 2 + 2 * i)) = 0 And Len(vDat(j, 3 + 2 * i)) = 0 Then
lineNo = lineNo + 3
Else
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
lineNo = lineNo + 4
End If
Next
' Output the result to a new sheet
Set shResult = Sheets.Add
With shResult
.Cells(1, 1).Value = "Part Code"
.Cells(1, 2).Value = "Subsection"
.Cells(1, 3).Value = "Time"
.Cells(1, 4).Value = "Text"
End With
shResult.Range("A2").Resize(UBound(resDat, 1), 4) = resDat
End Sub
thanks in advance for taking the time to help. I have built a Do While loop in VBA that for some reason breaks when j = 1. I have in cells C3:C7 these values: 13,14,14,13,14.
Here's the short script:
Dim i, j, n As Integer
Dim List(0) As Integer
i = o
j = 0
n = 0
Do While Cells(i + 3, 3) <> ""
If Cells(i + 3, 3) > 13 Then
List(j) = i + 3
j = j + 1
Cells(i + 3, 4) = "Noted"
i = i + 1
ElseIf Cells(i + 3, 3) = 13 Then
Cells(i + 3, 4) = "Skipped"
i = i + 1
Else
i = i + 1
End If
Loop
For n = j To n = 0
Rows(List(n)).Delete
Next
Thanks again!
Your intent is sound, but there are quite a few errors. See commented code below for details
Sub Demo()
' ~~ must explicitly type each variable. Use Long
Dim i As Long, j As Long, n As Long
Dim List() As Long '<~~ dynamic array
i = 3 '<~~ eliminate the klunky +3
j = 0
n = 0
ReDim List(0 To 0) '<~~ initialise dynamic array
Do While Cells(i, 3) <> vbNullString
If Cells(i, 3) > 13 Then
ReDim Preserve List(0 To j) '<~~ resize array
List(j) = i
j = j + 1
Cells(i, 4) = "Noted"
ElseIf Cells(i, 3) = 13 Then
Cells(i, 4) = "Skipped"
End If
i = i + 1 '<~~ simplify, its called in each if case anyway
Loop
' j will end up 1 greater than size of array
If j > 0 Then '<~~ only execute if we found some rows to delete
For n = j - 1 To 0 Step -1 '<~~ For loop syntax
Rows(List(n)).Delete
Next
End If
End Sub
I am trying parse a number string and create rows accordingly. On the left of the Example Data picture is an example of the input data with the right being my desired output. I am wanting to insert a unique row of data for each digit within the brackets for each number combination.
Here is an example of the code I used to try to solve the problem.
Option Explicit
Sub example()
Dim num As Variant
Dim x As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim test As Variant
Dim test2 As Variant
Dim count As Integer
m = 0
For i = 1 To 3
num = Range("C" & 5 + i + m).Value
For j = 1 To Len(num)
test = Mid(num, j)
If Left(Mid(num, j), 1) = "[" Then
For k = 1 To Len(num) - (j + 1)
m = m + 1
Range("C" & 5 + m + i - 1).EntireRow.Insert
test2 = Left(Mid(num, j + k), 1)
Range("C" & 5 + m + i - 1).Value = Left(num, j - 1) + test2
Next k
End If
Next j
Next i
End Sub
Please consider using the following script:
Sub splitcombinations()
Dim rngCell As Range
Set rngCell = ThisWorkbook.Sheets(1).Range("A2")
Dim strCombinationDigits As String, strBaseDigits As String
Dim intCombinationDigitsLen As Integer
Dim x As Integer
Do While rngCell.Value2 <> ""
If InStr(rngCell.Value2, "[") > 0 Then
strCombinationDigits = Mid(rngCell.Value2, InStr(rngCell.Value2, "[") + 1, InStr(rngCell.Value2, "]") - InStr(rngCell.Value2, "[") - 1)
intCombinationDigitsLen = Len(strCombinationDigits)
strBaseDigits = Left(rngCell.Value2, InStr(rngCell.Value2, "[") - 1)
ActiveSheet.Range(rngCell.Offset(1, 0), rngCell.Offset(intCombinationDigitsLen - 1, 0)).EntireRow.Insert
For x = 1 To intCombinationDigitsLen
rngCell.Offset(x - 1, 0).Value2 = strBaseDigits & Mid(strCombinationDigits, x, 1)
rngCell.Offset(x - 1, 1).Value2 = rngCell.Offset(0, 1).Value2
rngCell.Offset(x - 1, 2).Value2 = rngCell.Offset(0, 2).Value2
Next
End If
Set rngCell = rngCell.Offset(intCombinationDigitsLen , 0)
Loop
End Sub
Hello I have three columns with filled with names. So far I need to extract the three first cells of each column and put all the 15 names into a forth column. But if there are duplicates I must not put them in the list.
So far I got into
Private Sub CommandButton1_Click()
Dim temp(15) As String
Dim array1(5) As String
Dim array2(5) As String
Dim array3(5) As String
Dim i As Integer
Dim j As Integer
For i = 1 To 5
array1(i) = Cells(i + 3, 1).Value
array2(i) = Cells(i + 3, 4).Value
array3(i) = Cells(i + 3, 7).Value
Next i
temp(1) = array1(1)
temp(2) = array1(2)
temp(3) = array1(3)
temp(4) = array1(4)
temp(5) = array1(5)
temp(6) = array2(1)
temp(7) = array2(2)
temp(8) = array2(3)
temp(9) = array2(4)
temp(10) = array2(5)
temp(11) = array3(1)
temp(12) = array3(2)
temp(13) = array3(3)
temp(14) = array3(4)
temp(15) = array3(5)
For i = 1 To 15
For j = 1 To 15
If (temp(i) = temp(j + 1)) Then
Else
Cells(i + 4, 10).Value = temp(i)
End If
Next j
j = 0
Next i
End Sub
For i = 1 to 3
Cells(6 * i - 5, 10).Resize(5, 1).Value = Cells(6 * i - 5, 4 * i - 3).Resize(5,1).Value
Next
Application.DisplayAlerts = False
Cells(1, 10).Resize(15, 1).RemoveDuplicates Columns:=1, Header:=xlNo
Application.DisplayAlerts = True