Nested For Loop in Excel VBA - excel

The following code is working for only when c = 2 ,however I want it to work for other values as well. Below is the Excel table on which I want to run it.
Date PickupCost StorageCost DeliveryCost
1/1/2017 140 35 0
1/8/2017 80 20 0
1/10/2017 0 0 149
1/30/2017 35 8 0
I want to fill data of each date missing but only the value at column 3 (StorageCost) needs to be same in other missing date values as previous day's StorageCost value.
Dim j, p, w, c As Long
Dim date1, date2 As Date
j = Cells(Rows.Count, 1).End(xlUp).Row
w = 2
For c = w To j
date1 = Range("A" & w).Value
date2 = Range("A" & (w + 1)).Value
p = DateDiff("d", date1, date2)
For w = 2 To p
Range("A" & (c + 1)).EntireRow.Insert
ActiveSheet.Cells(c + 1, 1).Value = (ActiveSheet.Cells(c, 1).Value) + 1
ActiveSheet.Cells(c + 1, 2).Value = 0
ActiveSheet.Cells(c + 1, 3).Value = ActiveSheet.Cells(c, 3).Value
ActiveSheet.Cells(c + 1, 4).Value = 0
c = c + 1
Next w
w = w + 1
ActiveSheet.Range("A1").Select
j = Cells(Rows.Count, 1).End(xlUp).Row
Next c


Your main problem is that once you defined your For c = w To j loop then it will only run until it reaches value j had when you defined the for loop.
If you want an endpoint to the loop that adapts to the runtime changing number of rows, you should use a Do Until loop, like this:
Dim p As Long
Dim c, w As Integer
Dim date1, date2 As Date
c = 2
Do Until c = Cells(Rows.Count, 1).End(xlUp).Row
date1 = Range("A" & c).Value
date2 = Range("A" & (c + 1)).Value
p = DateDiff("d", date1, date2)
For w = c To c + p - 2
Range("A" & (w + 1)).EntireRow.Insert
ActiveSheet.Cells(w + 1, 1).Value = (ActiveSheet.Cells(c, 1).Value) + 1
ActiveSheet.Cells(w + 1, 2).Value = 0
ActiveSheet.Cells(w + 1, 3).Value = ActiveSheet.Cells(c, 3).Value
ActiveSheet.Cells(w + 1, 4).Value = 0
c = c + 1
Next w
c = c + 1
Loop

Related

Calculating Portfolio from one data series

I am supposed to make two market portfolios from the reversal strategy from the data given of value weighted market returns. However, I am stuck at how to proceed.
Sub REV1()
Dim c As Integer, r As Integer, g As Integer, x As Integer
Application.ScreenUpdating = False
lr = Sheets("VWMR").Cells(Rows.Count, 1).End(xlUp).Row
lc = Sheets("MRM").Cells(1, Columns.Count).End(xlToLeft).Column
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(ActiveSheet.Name).Name = "REV1"
ReDim r1(lr - 2) As Variant
ReDim r2(lr - 2) As Variant
ReDim r3(lr - 2) As Variant
ReDim r4(lr - 2) As Variant
ReDim r5(lr - 2) As Variant
ReDim r6(lr - 2) As Variant
Columns("A:C").ColumnWidth = 20
For h = 1 To 2
B = 2
x = 2
For r = 2 To lr - 2 - h
Set n = Range(Sheets("VWMR").Cells(x, 2), Sheets("VWMR").Cells(x, lc))
Set m = Range(Sheets("VWMR").Cells(x + h, 2), Sheets("VWMR").Cells(x + h, lc)) _
cn = Application.WorksheetFunction.Count(n)
cm = Application.WorksheetFunction.Count(m)
If cn > 10 And cm > 10 Then
D2 = Application.WorksheetFunction.Percentile(n, 0.1)
D3 = Application.WorksheetFunction.Percentile(n, 0.9)
r2(r) = Application.WorksheetFunction.AverageIfs(m, n, "<=" & D2)
r3(r) = Application.WorksheetFunction.AverageIfs(m, n, ">=" & D3)
Sheets("REV1").Cells(B + h - 1, h + 1).Value = r2(r) - r3(r)
Sheets("REV1").Cells(B, 1).Value = Sheets("VVMR").Cells(B + 1, 1).Value
End If
B = B + 1
x = x + 1
Next
Sheets("REV1").Cells(1, h + 1).Value = "MOM" & h
Next
Sheets("REV1").Cells(1, 1).Value = "Dates"
Application.ScreenUpdating = True
Set a1 = Range(Sheets("REV1").Cells(2, 2), Sheets("REV1").Cells(lr, 2))
D = Application.WorksheetFunction.Average(a1)
MsgBox "The annual reversal returns are " & Format(Exp(D) - 1, "") & "."
End Sub
This is the code I tried to take out one portfolio first but this is not working.

How to find the frequency of each criteria in the same column in Excel VBA

'''
Sub SummaryDemographics()
Set dt = Worksheets("Data")
Set ans = Worksheets("Answer")
Set s1 = Worksheets("Summary 1")
'print headers
j = 2
i = 1
LR = 0
For i = 1 To 6: 'loop rows in 'Answer' sheet
s1.Cells(LR + 1, 1) = ans.Cells(i, 1) 'question
s1.Cells(LR + 1, 2) = "Percentage"
For j = 2 To 7: 'loop through columns in 'answer' sheet
Do Until ans.Cells(i, j).Value = ""
LR = s1.Cells(Rows.Count, 1).End(xlUp).Row + 1
s1.Cells(LR, 1) = Right(ans.Cells(i, j), Len(ans.Cells(i, j)) - 2)
s1.Cells(LR, 2) = WorksheetFunction.CountIf(dt.Cells(9, i + 1).End(xlDown), i)
j = j + 1
Loop
Next j
LR = LR + 1
Next i
End Sub'''
The above coding is what I tried out, but it cannot count the frequency of each variable in the column. Like for sex, it's output is 1 and 1 for male and female respectively. I haven't tried to calculate the percentage, since I can't even count the frequency of each variable

Insert a row n times

I´ve an Excel file with 10 Columns. In columns 2, 3, 4 I have a number or a dash.
If the sum of these 3 cells is greater than 1, I need to replace that entire row with n rows that have only one of the columns with the value 1 but the other cells stay the same.
Example
1 - - #-> leave it as is
- 2 - #-> replace that row with 2 rows : - 1 - ; - 1 -
2 - 1 #-> replace that row with 3 rows : 1 - - ; 1 - - ; - - 1;
I managed to iterate from bottom up, but I´m having trouble storing a row in memory, manipulate it and insert below.
Sub Test()
Dim rng As Range
Dim count20, count40, count45, total, i As Integer
Set rng = Range("A3", Range("A3").End(xlDown))
For i = rng.Cells.count To 1 Step -1
count20 = 0
count40 = 0
count45 = 0
total = 0
count20 = Cells(rng.Item(i).Row, 10).Value
If count20 > 1 Then
total = total + count20
End If
count40 = Cells(rng.Item(i).Row, 11).Value
If count40 > 1 Then
total = total + count40
End If
count45 = Cells(rng.Item(i).Row, 12).Value
If count45 > 1 Then
total = total + count45
End If
If total <> 0 Then
MsgBox total
End If
Next i
End Sub

EDIT 2
I’ve provided alternative code based on your latest comment. It uses columns J-L (10-12) as the numeric cells to be changed, and columns A-I (1-9) and M-AD (13-30) as the cells with text to be preserved. As before, sheet 1 starting in row 3 is assumed, and you can change this to whatever you need.
Option Explicit
Sub testJtoL()
Dim LastRow As Long, i As Long, j As Long, c As Long, _
insertR As Long, TopRow As Long, BottomRow As Long
Dim b As Range
Dim ws As Worksheet
'*** This code is based your values being in Columns J-L (10-12) in sheet 1 ***
'Set sheet 1 as ws
Set ws = Sheet1
'Sheet1 column J is used here to get your last row
LastRow = ws.Cells(Rows.Count, 10).End(xlUp).Row
'*** This code is based your values starting in Row 3 ***
For c = LastRow To 3 Step -1
'Determine number of rows to insert based on sum of that row
insertR = Application.WorksheetFunction.Sum(Range(Cells(c, 10), Cells(c, 12))) - 1
If insertR = 0 Then GoTo skip
'STEP 1 insert the correct number of rows
With ws.Range(Cells(c + 1, 1), Cells(c + insertR, 30))
.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
End With
'STEP 2 fill the values into the correct number of rows
insertR = insertR + 1
With ws.Range(Cells(c, 1), Cells(c, 30))
.Resize(insertR, 30).Value = .Value
End With
TopRow = c
If insertR = 0 And c = 3 Then
BottomRow = c
Else
BottomRow = c + insertR - 1
End If
'STEP 3 replace all numbers with 1 or "-"
'Replace numbers in column J
If ws.Range(Cells(c, 10), Cells(c, 10)).Value = "-" Then GoTo SkipA
i = ws.Range(Cells(c, 10), Cells(c, 10)).Value
j = 1
For Each b In ws.Range(Cells(TopRow, 10), Cells(BottomRow, 10))
If j <= i Then
b.Value = 1
b.Offset(0, 1).Value = "-"
b.Offset(0, 2).Value = "-"
Else
b.Value = "-"
End If
j = j + 1
Next b
SkipA:
'Replace numbers in column K
j = 1
For Each b In ws.Range(Cells(TopRow, 11), Cells(BottomRow, 11))
If b.Value = "-" Then GoTo SkipB
i = b.Value
If j <= i Then
b.Value = 1
b.Offset(0, 1).Value = "-"
Else
b.Value = "-"
End If
j = j + 1
SkipB:
Next b
'Replace numbers in column L
j = 1
For Each b In ws.Range(Cells(TopRow, 12), Cells(BottomRow, 12))
If b.Value = "-" Then GoTo SkipC
i = b.Value
If j <= i Then
b.Value = 1
Else
b.Value = "-"
End If
j = j + 1
SkipC:
Next b
skip:
Next c
End Sub

Case Statement, for loop and if...else in VBA

In the above column i have unique date.
I have a drop down list where anything can be selected.. so it has 8 permutation(2^3)..So i want to extract probable date based on the selection..Suppose if i select Year as 2020 and day as 19 then i will extract the probable date which match both the condition..Like above picture...
Right now i am using 8 if elseif-=...end if statment...and for loop..Is there any other way to do the same work?? I wanted to write a function which will take (day,month,year,lastrow) as parameter and based on probable date will be calculated..Can anyone give me any idea how to do it?
My code now:
Public Sub ProbableDate(CaseNo As Integer, lastrow As Long)
Dim sh As Worksheet, sh1 As Worksheet
Set sh1 = Worksheets("Dashboard")
Set sh = Worksheets("Logical operation")
Dim Y As String, M As String, D As String
Y = sh1.Cells(4, 1).Value
M = sh1.Cells(4, 2).Value
D = sh1.Cells(4, 3).Value
Dim L As Long, i As Long
L = 2
With sh
.Range("H2:H1048576").Clear
For i = 2 To lastrow
Select Case CaseNo
Case 1
If Year(.Cells(i, 2).Value) = Y Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 2
If MonthName(Month(.Cells(i, 2).Value)) = M Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 3
If Day(.Cells(i, 2).Value) = D Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 4
If Year(.Cells(i, 2).Value) = Y And MonthName(Month(.Cells(i, 2).Value)) = M Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 5
If Year(.Cells(i, 2).Value) = Y And Day(.Cells(i, 2).Value) = D Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 6
If Day(.Cells(i, 2).Value) = D And MonthName(Month(.Cells(i, 2).Value)) = M Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case 7
If Day(.Cells(i, 2).Value) = D And MonthName(Month(.Cells(i, 2).Value)) = M And Year(.Cells(i, 2).Value) = Y Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
End If
Case Else
MsgBox "Wrong Info"
End Select
Next i
End With
End Sub

You can simplify your code using a binary lookup table. Each CaseNo matches with a particular set of true/false outcomes for the day, month and year check. These are different to your original mapping, here is the new map:
CaseNo DMY
0 fail
1 D
2 M
3 DM
4 Y
5 D Y
6 MY
7 DMY
And the code:
With sh
.Range("H:H").Clear
For i = 2 To lastrow
OK = 0
If Day(.Cells(i, 2).Value) = D Then OK = OK + 1
If MonthName(Month(.Cells(i, 2).Value)) = M Then OK = OK + 2
If Year(.Cells(i, 2).Value) = Y Then OK = OK + 4
If OK = CaseNo Then
.Cells(L, 8).Value = .Cells(i, 2).Value
L = L + 1
Else
MsgBox "Wrong Info"
End If
Next i
End With

Code works with two products but when I add a third product code grabs data but doesn't save it only for third product. What's wrong with it?

The code still works for oil and gas. It will find and pull in the refined data, I can see it on the current prices worksheet while it's running but when it's finished running it will delete the refined data and doesn't populate any of the other sheets for refined only. I copied all code bits for oil and replaced the word oil with refined.
Sub Prices()
Dim asOfDate As Date
Dim i, c, r As Integer
Dim break As Integer
Dim wf As WorksheetFunction
ws_currentprices.Activate
'Copy date from summary ws to pop asofdate
Cells(ASOFDATE_ROW, BUCKET_COL) = ws_summary.Cells(1, 6)
If IsEmpty(Cells(ASOFDATE_ROW, BUCKET_COL)) Then
asOfDate = Date
Else
asOfDate = Cells(ASOFDATE_ROW, BUCKET_COL)
End If
'Setting to manual calculation must happen after asofdate has been populated
Application.Calculation = xlManual
'Clear all data and headers from the current prices ws
Range(Cells(STATUS_ROW, FIRSTDATA_COL), Cells(110, 50)).ClearContents
Set wf = Application.WorksheetFunction
'Build arraylist of gas markets
Dim gasArray As Object
Set gasArray = CreateObject("System.Collections.ArrayList")
i = 1
Do Until (IsEmpty(ws_gasmarkets.Cells(i, 4)))
If StrComp(ws_gasmarkets.Cells(i, 4), "Yes", vbTextCompare) = 0 Then gasArray.Add ws_gasmarkets.Cells(i, 2).Value
i = i + 1
Loop
'Process arraylist of gas markets
c = FIRSTDATA_COL
For i = 0 To gasArray.Count - 1
Days = 0
Do Until Month(wf.WorkDay(asOfDate, Days)) <> Month(asOfDate)
Cells(COMMODITY_ROW, c) = gasArray(i)
Cells(ASOFDATE_ROW, c) = CDate(wf.WorkDay(asOfDate, Days))
Cells(DATASOURCE_ROW, c) = "Official"
Cells(MARKETTYPE_ROW, c) = "Gas"
break = c - 1
c = c + 1
Days = Days - 1
Loop
Cells(COMMODITY_ROW, c) = gasArray(i)
Cells(ASOFDATE_ROW, c) = dhLastDayInMonth(DateSerial(Year(asOfDate), Month(asOfDate) - 1, 1))
Cells(DATASOURCE_ROW, c) = "Official"
Cells(MARKETTYPE_ROW, c) = "Gas"
break = c - 1
c = c + 1
Next
'Build arraylist of oil markets
Dim oilArray As Object
Set oilArray = CreateObject("System.Collections.ArrayList")
i = 1
Do Until (IsEmpty(ws_oilmarkets.Cells(i, 4)))
If StrComp(ws_oilmarkets.Cells(i, 4), "Yes", vbTextCompare) = 0 Then oilArray.Add ws_oilmarkets.Cells(i, 2).Value
i = i + 1
Loop
'Process arraylist of oil markets
For i = 0 To oilArray.Count - 1
Days = 0
Do Until Month(wf.WorkDay(asOfDate, Days)) <> Month(asOfDate)
Cells(COMMODITY_ROW, c) = oilArray(i)
Cells(ASOFDATE_ROW, c) = CDate(wf.WorkDay(asOfDate, Days))
Cells(DATASOURCE_ROW, c) = "Official"
Cells(MARKETTYPE_ROW, c) = "Oil"
break = c - 1
c = c + 1
Days = Days - 1
Loop
Cells(COMMODITY_ROW, c) = oilArray(i)
Cells(ASOFDATE_ROW, c) = dhLastDayInMonth(DateSerial(Year(asOfDate), Month(asOfDate) - 1, 1))
Cells(DATASOURCE_ROW, c) = "Official"
Cells(MARKETTYPE_ROW, c) = "Oil"
break = c - 1
c = c + 1
Next
'Build arraylist of REFINED markets
Dim REFINEDArray As Object
Set REFINEDArray = CreateObject("System.Collections.ArrayList")
i = 1
Do Until (IsEmpty(ws_REFINEDmarkets.Cells(i, 4)))
If StrComp(ws_REFINEDmarkets.Cells(i, 4), "Yes", vbTextCompare) = 0 Then REFINEDArray.Add ws_REFINEDmarkets.Cells(i, 2).Value
i = i + 1
Loop
'Process arraylist of REFINED markets
For i = 0 To REFINEDArray.Count - 1
Days = 0
Do Until Month(wf.WorkDay(asOfDate, Days)) <> Month(asOfDate)
Cells(COMMODITY_ROW, c) = REFINEDArray(i)
Cells(ASOFDATE_ROW, c) = CDate(wf.WorkDay(asOfDate, Days))
Cells(DATASOURCE_ROW, c) = "Official"
Cells(MARKETTYPE_ROW, c) = "REFINED"
break = c - 1
c = c + 1
Days = Days - 1
Loop
Cells(COMMODITY_ROW, c) = REFINEDArray(i)
Cells(ASOFDATE_ROW, c) = dhLastDayInMonth(DateSerial(Year(asOfDate), Month(asOfDate) - 1, 1))
Cells(DATASOURCE_ROW, c) = "Official"
Cells(MARKETTYPE_ROW, c) = "Refined"
break = c - 1
c = c + 1
Next
'Downloads current prices from Kiodex
DownloadCurrentPrices
'Remove invalid pricing columns
If (PricesCleanup) Then
'Setup GAS and OIL worksheets
REFINEDSetup
GasSetup
OilSetup
'Calculate GAS and OIL worksheets
ws_REFINED.Calculate
ws_oil.Calculate
ws_gas.Calculate
'Refresh and display summary worksheet
'ws_summary.Calculate
Calculate
ws_summary.Activate
Refresh
'Set data source value based on NYMEX - Not Updated (0), Preliminary (1), or Updated (2)
c = FIRSTDATA_COL
ds = 0
gaschk = False
oilchk = False
REFINEDchk = False
Do Until (IsEmpty(ws_currentprices.Cells(COMMODITY_ROW, c)) Or (gaschk And oilchk And REFINEDchk))
If (StrComp(ws_currentprices.Cells(COMMODITY_ROW, c), "GD Henry Hub", vbTextCompare) And Not gaschk) Then
If (ws_currentprices.Cells(ASOFDATE_ROW, c) = ws_currentprices.Cells(ASOFDATE_ROW, BUCKET_COL)) Then
'Data for current date
If (StrComp(ws_currentprices.Cells(DATASOURCE_ROW, c), "Official", vbTextCompare) = 0) Then
'Data is official
ds = ds + 2
Else
'Data is global
ds = ds + 1
End If
Else
'Data for prior date
ds = ds + 0
End If
gaschk = True
End If
If (StrComp(ws_currentprices.Cells(COMMODITY_ROW, c), "NYMEX WTI", vbTextCompare) And Not oilchk) Then
If (ws_currentprices.Cells(ASOFDATE_ROW, c) = ws_currentprices.Cells(ASOFDATE_ROW, BUCKET_COL)) Then
'Data for current date
If (StrComp(ws_currentprices.Cells(DATASOURCE_ROW, c), "Official", vbTextCompare) = 0) Then
'Data is official
ds = ds + 2
Else
'Data is global
ds = ds + 1
End If
Else
'Data for prior date
ds = ds + 0
End If
oilchk = True
End If
'***REFINED addition***
If (StrComp(ws_currentprices.Cells(COMMODITY_ROW, c), "OPIS Ethane Mt Belv non TET", vbTextCompare) And Not REFINEDchk) Then
If (ws_currentprices.Cells(ASOFDATE_ROW, c) = ws_currentprices.Cells(ASOFDATE_ROW, BUCKET_COL)) Then
'Data for current date
If (StrComp(ws_currentprices.Cells(DATASOURCE_ROW, c), "Official", vbTextCompare) = 0) Then
'Data is official
ds = ds + 2
Else
'Data is global
ds = ds + 1
End If
Else
'Data for prior date
ds = ds + 0
End If
REFINEDchk = True
End If
c = c + 1
Loop
Select Case ds
Case Is >= 4
ws_summary.Range("SummaryDataSource") = "Updated"
Case Is > 0
ws_summary.Range("SummaryDataSource") = "Preliminary"
Case Else
ws_summary.Range("SummaryDataSource") = "Not Updated"
End Select
Else
ws_summary.Activate
ws_summary.Range("SummaryDataSource") = "Not Updated"
End If
'Set last updated date
ws_summary.Range("LastUpdatedDateTime") = Now
Application.Calculation = xlAutomatic
Application.ReferenceStyle = xlA1
'Update BOKF Pricing History
If Format(asOfDate, "m/d/yyyy") = Format(WorksheetFunction.WorkDay(WorksheetFunction.EoMonth(asOfDate, 0) + 1, -1), "m/d/yyyy") Then
Call UpdateBOKFPriceHistory(Format(DateSerial(Year(asOfDate), Month(asOfDate) + 1, 1), "mm/dd/yyyy"), False)
End If
End Sub
'This function checks the Current Prices tab for any columns that are duplicates of the day before or weekends and deletes the column
Function PricesCleanup() As Boolean
Dim r, c As Integer
Dim removeCount As Integer
Dim removeColumn As Boolean
Dim isGas, isOil, isREFINED As Boolean
c = FIRSTDATA_COL
removeCount = 0
Do Until IsEmpty(ws_currentprices.Cells(COMMODITY_ROW, c)) 'check every col of prices
'Start at the row of the first date and reset remove flag
r = FIRSTDATE_ROW
removeColumn = True
'Check each column, at least until there is a discrepancy between prices so we know it's not a holiday
Do Until ((r > 12 And IsEmpty(ws_currentprices.Cells(r, c))) Or r > 60 Or Not removeColumn)
'If the prices don't match, we know it's not a holiday
If (ws_currentprices.Cells(r, c) <> ws_currentprices.Cells(r, c + 1)) Then
'If the first row is empty or matches second row, it's likely due to near EoM index shifting and requires special handling
If r = FIRSTDATE_ROW Then
If IsEmpty(ws_currentprices.Cells(r, c)) Then
'Oil index swap
removeColumn = False
End If
If (ws_currentprices.Cells(r, c) = ws_currentprices.Cells(r + 1, c) And ws_currentprices.Cells(MARKETTYPE_ROW, c) = "Gas") Then
removeColumn = False
End If
'***Refined
If (ws_currentprices.Cells(r, c) = ws_currentprices.Cells(r + 1, c) And ws_currentprices.Cells(MARKETTYPE_ROW, c) = "REFINED") Then
removeColumn = False
End If
Else
'Not index related and no match, so don't remove column
removeColumn = False
End If
End If
r = r + 1
Loop
'Check for weekend dates or dates from prior month
If Weekday(ws_currentprices.Cells(ASOFDATE_ROW, c)) = 1 Or Weekday(ws_currentprices.Cells(ASOFDATE_ROW, c)) = 7 Or Month(ws_currentprices.Cells(ASOFDATE_ROW, c)) <> Month(ws_currentprices.Cells(ASOFDATE_ROW, BUCKET_COL)) Then
removeColumn = True
End If
'Remove column if flagged
If removeColumn Then
removeCount = removeCount + 1
ws_currentprices.Columns(c).EntireColumn.Delete
c = c - 1
End If
'Copy up spot price
If Not IsEmpty(ws_currentprices.Cells(FIRSTDATE_ROW, c)) Then
ws_currentprices.Cells(SPOT_ROW, c) = ws_currentprices.Cells(FIRSTDATE_ROW, c)
ElseIf Not IsEmpty(ws_currentprices.Cells(FIRSTDATE_ROW + 1, c)) Then
ws_currentprices.Cells(SPOT_ROW, c) = ws_currentprices.Cells(FIRSTDATE_ROW + 1, c)
Else
ws_currentprices.Cells(SPOT_ROW, c) = ""
End If
c = c + 1
Loop
'Check if any columns are left and return bool value
isGas = False
isOil = False
isREFINED = False
c = FIRSTDATA_COL
Do Until IsEmpty(ws_currentprices.Cells(COMMODITY_ROW, c))
If (ws_currentprices.Cells(MARKETTYPE_ROW, c) = "Gas") Then
isGas = True
ElseIf (ws_currentprices.Cells(MARKETTYPE_ROW, c) = "Oil") Then
isOil = True
ElseIf (ws_currentprices.Cells(MARKETTYPE_ROW, c) = "Refined") Then
isREFINED = True
End If
c = c + 1
Loop
If (isGas And isOil And isREFINED) Then
PricesCleanup = True
Else
PricesCleanup = False
End If
End Function
Sub GasSetup()
Dim cpr, cpc, r, c, marketcount, marketstartrow As Integer
Dim index As Double
Const YEARMONTH_COL = 1
Const DATE_COL = 2
Const SPOT_COL = 3
Const markettype = "GAS"
ws_gas.UsedRange.ClearContents
cpc = FIRSTDATA_COL
marketcount = 0
'Loop through each column in currentprices looking for gas markets
Do Until (IsEmpty(ws_currentprices.Cells(COMMODITY_ROW, cpc)))
If StrComp(ws_currentprices.Cells(MARKETTYPE_ROW, cpc), markettype, vbTextCompare) = 0 Then
'This is a gas column
cpr = FIRSTDATE_ROW
c = 1
If StrComp(ws_currentprices.Cells(COMMODITY_ROW, cpc), ws_currentprices.Cells(COMMODITY_ROW, cpc - 1), vbTextCompare) <> 0 Then
'Sort prior market data by date
If marketcount <> 0 Then
ws_gas.Range("A" & marketstartrow + 1 & ":FF" & r).Sort Key1:=ws_gas.Range("B" & marketstartrow + 1 & ":FF" & r), _
order1:=xlAscending, Header:=xlYes
End If
'Start each new market on row divisible by 30 + 1 to prevent any issues with summary table
marketstartrow = marketcount * 30 + 1
marketcount = marketcount + 1
r = marketstartrow
'Add labels for new market
ws_gas.Cells(r, YEARMONTH_COL) = ws_currentprices.Cells(COMMODITY_ROW, cpc)
ws_gas.Cells(r + 1, YEARMONTH_COL) = "YEARMONTH"
ws_gas.Cells(r + 1, DATE_COL) = "Date"
ws_gas.Cells(r + 1, SPOT_COL) = "Spot"
c = c + 3
For i = 0 To 59
ws_gas.Cells(r + 1, c + i) = i + 1
Next
r = r + 2
End If
'Populate date
ws_gas.Cells(r, DATE_COL) = ws_currentprices.Cells(ASOFDATE_ROW, cpc)
ws_gas.Cells(r, YEARMONTH_COL) = Year(ws_gas.Cells(r, DATE_COL)) & "." & Month(ws_gas.Cells(r, DATE_COL))
'Populate spot
ws_gas.Cells(r, SPOT_COL) = ws_currentprices.Cells(SPOT_ROW, cpc)
c = 4
'Populate row
Do Until cpr > 60 And IsEmpty(ws_currentprices.Cells(cpr, cpc))
ws_gas.Cells(r, c) = ws_currentprices.Cells(cpr, cpc)
cpr = cpr + 1
c = c + 1
Loop
r = r + 1
End If
cpc = cpc + 1
Loop
'Sort final market data by date
ws_gas.Range("A" & marketstartrow + 1 & ":FF" & r).Sort Key1:=ws_gas.Range("B" & marketstartrow + 1 & ":B" & r), _
order1:=xlAscending, Header:=xlYes
'Iterate through the Nymex data to update market index values
r = 2
index = 0
Do Until (IsEmpty(ws_gas.Cells(r, DATE_COL)))
If IsEmpty(ws_gas.Cells(r, DATE_COL + 2)) Then
'No value for current month, so take prior row value for index
Call UpdateIndexes(markettype, ws_gas.Cells(r - 1, DATE_COL), ws_gas.Cells(r - 1, DATE_COL + 2))
Exit Do
End If
r = r + 1
Loop
End Sub
Sub OilSetup()
Dim cpr, cpc, r, c, marketcount, marketstartrow As Integer
Dim index As Double
Const YEARMONTH_COL = 1
Const DATE_COL = 2
Const SPOT_COL = 3
Const markettype = "OIL"
ws_oil.UsedRange.ClearContents
cpc = FIRSTDATA_COL
marketcount = 0
marketstartrow = 0
'Loop through each column in currentprices looking for gas markets
Do Until (IsEmpty(ws_currentprices.Cells(COMMODITY_ROW, cpc)))
If StrComp(ws_currentprices.Cells(MARKETTYPE_ROW, cpc), markettype, vbTextCompare) = 0 Then
'This is a gas column
cpr = FIRSTDATE_ROW
c = 1
If StrComp(ws_currentprices.Cells(COMMODITY_ROW, cpc), ws_currentprices.Cells(COMMODITY_ROW, cpc - 1), vbTextCompare) <> 0 Then
'Sort prior market data by date
If marketcount <> 0 Then
ws_oil.Range("A" & marketstartrow + 1 & ":FF" & r).Sort Key1:=ws_oil.Range("B" & marketstartrow + 1 & ":FF" & r), _
order1:=xlAscending, Header:=xlYes
End If
'Start each new market on row divisible by 30 + 1 to prevent any issues with summary table
marketstartrow = marketcount * 30 + 1
marketcount = marketcount + 1
r = marketstartrow
'Add labels for new market
ws_oil.Cells(r, YEARMONTH_COL) = ws_currentprices.Cells(COMMODITY_ROW, cpc)
ws_oil.Cells(r + 1, YEARMONTH_COL) = "YEARMONTH"
ws_oil.Cells(r + 1, DATE_COL) = "Date"
ws_oil.Cells(r + 1, SPOT_COL) = "Spot"
c = c + 3
For i = 0 To 59
ws_oil.Cells(r + 1, c + i) = i + 1
Next
r = r + 2
End If
'Populate date
ws_oil.Cells(r, DATE_COL) = ws_currentprices.Cells(ASOFDATE_ROW, cpc)
ws_oil.Cells(r, YEARMONTH_COL) = Year(ws_oil.Cells(r, DATE_COL)) & "." & Month(ws_oil.Cells(r, DATE_COL))
'Populate spot
ws_oil.Cells(r, SPOT_COL) = ws_currentprices.Cells(SPOT_ROW, cpc)
c = 4
'Populate row
Do Until cpr > 60 And IsEmpty(ws_currentprices.Cells(cpr, cpc))
ws_oil.Cells(r, c) = ws_currentprices.Cells(cpr, cpc)
cpr = cpr + 1
c = c + 1
Loop
r = r + 1
End If
cpc = cpc + 1
Loop
'Sort final market data by date
ws_oil.Range("A" & marketstartrow + 1 & ":FF" & r).Sort Key1:=ws_oil.Range("B" & marketstartrow + 1 & ":B" & r), _
order1:=xlAscending, Header:=xlYes
'Iterate through the Nymex data to update market index values
r = 2
index = 0
Do Until (IsEmpty(ws_oil.Cells(r, DATE_COL)))
If IsEmpty(ws_oil.Cells(r, DATE_COL + 2)) Then
'No value for current month, so take prior row value for index
Call UpdateIndexes(markettype, ws_oil.Cells(r - 1, DATE_COL), ws_oil.Cells(r - 1, DATE_COL + 2))
Exit Do
End If
r = r + 1
Loop
End Sub
Sub REFINEDSetup()
Dim cpr, cpc, r, c, marketcount, marketstartrow As Integer
Dim index As Double
Const YEARMONTH_COL = 1
Const DATE_COL = 2
Const SPOT_COL = 3
Const markettype = "REFINED"
ws_REFINED.UsedRange.ClearContents
cpc = FIRSTDATA_COL
marketcount = 0
marketstartrow = 0
'Loop through each column in currentprices looking for REFINED markets
Do Until (IsEmpty(ws_currentprices.Cells(COMMODITY_ROW, cpc)))
If StrComp(ws_currentprices.Cells(MARKETTYPE_ROW, cpc), markettype, vbTextCompare) = 0 Then
'This is a REFINED column
cpr = FIRSTDATE_ROW
c = 1
If StrComp(ws_currentprices.Cells(COMMODITY_ROW, cpc), ws_currentprices.Cells(COMMODITY_ROW, cpc - 1), vbTextCompare) <> 0 Then
'Sort prior market data by date
If marketcount <> 0 Then
ws_REFINED.Range("A" & marketstartrow + 1 & ":FF" & r).Sort Key1:=ws_REFINED.Range("B" & marketstartrow + 1 & ":FF" & r), _
order1:=xlAscending, Header:=xlYes
End If
'Start each new market on row divisible by 30 + 1 to prevent any issues with summary table
marketstartrow = marketcount * 30 + 1
marketcount = marketcount + 1
r = marketstartrow
'Add labels for new market
ws_REFINED.Cells(r, YEARMONTH_COL) = ws_currentprices.Cells(COMMODITY_ROW, cpc)
ws_REFINED.Cells(r + 1, YEARMONTH_COL) = "YEARMONTH"
ws_REFINED.Cells(r + 1, DATE_COL) = "Date"
ws_REFINED.Cells(r + 1, SPOT_COL) = "Spot"
c = c + 3
For i = 0 To 59
ws_REFINED.Cells(r + 1, c + i) = i + 1
Next
r = r + 2
End If
'Populate date
ws_REFINED.Cells(r, DATE_COL) = ws_currentprices.Cells(ASOFDATE_ROW, cpc)
ws_REFINED.Cells(r, YEARMONTH_COL) = Year(ws_REFINED.Cells(r, DATE_COL)) & "." & Month(ws_REFINED.Cells(r, DATE_COL))
'Populate spot
ws_REFINED.Cells(r, SPOT_COL) = ws_currentprices.Cells(SPOT_ROW, cpc)
c = 4
'Populate row
Do Until cpr > 60 And IsEmpty(ws_currentprices.Cells(cpr, cpc))
ws_REFINED.Cells(r, c) = ws_currentprices.Cells(cpr, cpc)
cpr = cpr + 1
c = c + 1
Loop
r = r + 1
End If
cpc = cpc + 1
Loop
'Sort final market data by date
ws_REFINED.Range("A" & marketstartrow + 1 & ":FF" & r).Sort Key1:=ws_REFINED.Range("B" & marketstartrow + 1 & ":B" & r), _
order1:=xlAscending, Header:=xlYes
'Iterate through the Nymex data to update market index values
r = 2
index = 0
Do Until (IsEmpty(ws_REFINED.Cells(r, DATE_COL)))
If IsEmpty(ws_REFINED.Cells(r, DATE_COL + 2)) Then
'No value for current month, so take prior row value for index
Call UpdateIndexes(markettype, ws_REFINED.Cells(r - 1, DATE_COL), ws_REFINED.Cells(r - 1, DATE_COL + 2))
Exit Do
End If
r = r + 1
Loop
End Sub

StrComp in VBA does not return True or False. It returns -1, 0, or 1 depending on the results of the string comparison. If the two strings match for the particular type of comparison chosen then StrComp will return 0.
However, VBA treats 0 as being equivalent to False - see here. This means that if you write a StrComp where the two strings match, but you forget to compare the results to zero, then you will get a result of False if you use the result as if it were a Boolean (e.g. in an If statement).
In your code, you have:
If (StrComp(ws_currentprices.Cells(COMMODITY_ROW, c), "GD Henry Hub", vbTextCompare) And Not gaschk) Then
If (StrComp(ws_currentprices.Cells(COMMODITY_ROW, c), "NYMEX WTI", vbTextCompare) And Not oilchk) Then
If (StrComp(ws_currentprices.Cells(COMMODITY_ROW, c), "OPIS Ethane Mt Belv non TET", vbTextCompare) And Not REFINEDchk) Then
All three statements are incorrectly using the result of StrComp as if it were a Boolean. Change all three to StrComp(...) = 0 instead

Resources