I was asked to review this code to see why it is not populating the spread sheet chronogically. The problem is, this code is a little too (ok, alot) more advance than my understanding.
Without puttting anyone completely out, can anyone look at this code and see or tell me or advise me, why it may be taking the data out of the database and placing it out of order within the excel sheet? thanks!!!
I know its long...sorry
Public SheetName(35) As String
Public iPriceID As Integer
Sub Run_Report()
Dim iNumSheets As Integer
Dim iCount As Integer
Dim wSheet As Worksheet
Dim rs As Recordset
Dim sSql As String
Dim dBeginDate As Date
Dim dEndDate As Date
Dim dBeginMonth As Date
Dim dEndMonth As Date
Dim sGasDaily As String
Dim sPhysical As String
Dim iRow As Integer
Dim iColumn As Integer
Dim iCounter As Integer
Dim sMonth As String
Dim sYear As String
Dim sEndMonth As String
Dim sEndYear As String
Dim bNew As Boolean
Dim bNewPriceID As Boolean
Dim iSheet As Integer
Dim sRegion1 As String
Dim sRegion2 As String
On Error GoTo ErrHandler
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
If login_db = False Then End
'Begin and End Date
dBeginDate = Worksheets("FrontEnd").Range("BeginDate")
dEndDate = Worksheets("FrontEnd").Range("EndDate")
'Begin and End Month
dBeginMonth = Worksheets("FrontEnd").Range("BeginMonth")
dEndMonth = Worksheets("FrontEnd").Range("EndMonth")
'Get total number of worksheets
iNumSheets = ActiveWorkbook.Sheets.Count
iCount = 1
'Assign Names of worksheets to array
For Each wSheet In Worksheets
SheetName(iCount) = wSheet.Name
iCount = iCount + 1
Next wSheet
'Routine to retrieve and populate data for all curves
For iSheet = 4 To iNumSheets
bNewPriceID = False
bNew = False
sGasDaily = Worksheets(SheetName(iSheet)).Range("A1")
sPhysical = Worksheets(SheetName(iSheet)).Range("A5")
sMonth = Format(dEndMonth, "mm")
sYear = Format(dEndMonth, "yyyy")
sSql = ""
sSql = "SELECT "
sSql = sSql & "PE2.ContractMonth, "
sSql = sSql & "PE2.Price, "
sSql = sSql & "PE2.PriceID, "
sSql = sSql & "PL2.PriceDesc, "
sSql = sSql & "PE2.DateOf "
sSql = sSql & "FROM "
sSql = sSql & "dbo.PriceExact_V PE2, "
sSql = sSql & "dbo.PriceLookup_V PL2 "
sSql = sSql & "WHERE "
sSql = sSql & "PL2.PriceID = PE2.PriceID AND PE2.SubID = "
sSql = sSql & "CASE "
sSql = sSql & "WHEN PL2.Pricetable = 'ELE' "
sSql = sSql & "THEN PE2.SubID ELSE 0 "
sSql = sSql & "END "
sSql = sSql & "AND PE2.DateOf BETWEEN '" & dBeginDate & "' AND '" & dEndDate & "'"
sSql = sSql & "AND PE2.ContractMonth BETWEEN '" & dBeginMonth & "' AND '" & dEndMonth & "'"
sSql = sSql & "AND PL2.PriceDesc IN ('" & sGasDaily & "','" & sPhysical & "')"
Set rs = dbsSQLServer.OpenRecordset(sSql, dbOpenSnapshot, dbSQLPassThrough)
If Not rs.EOF Then
rs.MoveLast
rs.MoveFirst
End If
Worksheets(SheetName(iSheet)).Select
Range("3:4,7:8").Select
Selection.ClearContents
Range("A1").Select
'Column Names
iColumn = 1
For iCounter = 0 To rs.Fields.Count - 4
Cells((iCounter + 3), iColumn) = "" & rs.Fields(iCounter).Name
Next iCounter
Do While Not rs.EOF
iColumn = iColumn + 1
'First Region
If Not bNewPriceID Then
For iRow = 3 To 4
sEndMonth = Format(Trim(rs(Cells(iRow, 1))), "mm")
sEndYear = Format(Trim(rs(Cells(iRow, 1))), "yyyy")
If iRow = 3 And sEndYear = Format(dBeginMonth, "yyyy") _
And sEndMonth = Format(dBeginMonth, "mm") And iColumn <> 2 Then
'Cells(3, iColumn) = "" & Trim(rs(Cells(3, 1)))
'Cells(4, iColumn) = "" & Trim(rs(Cells(4, 1)))
'Cells(5, iColumn) = "" & Trim(rs(Cells(5, 1)))
'Cells(6, iColumn) = "" & Trim(rs(Cells(6, 1)))
'rs.MoveNext
bNew = True
iColumn = 2
Exit For
End If
Cells(iRow, iColumn) = "" & Trim(rs(Cells(iRow, 1)))
Next iRow
End If
'Second Region
If bNew Then
bNewPriceID = True
For iRow = 3 To 4
On Error Resume Next
Cells(iRow + 4, iColumn) = "" & Trim(rs(Cells(iRow, 1)))
Next iRow
End If
rs.MoveNext
Loop
rs.Close
'check for alphabetical order
sRegion1 = Left$(sGasDaily, 1)
sRegion2 = Left$(sPhysical, 1)
If sRegion2 < sRegion1 Then
GetPriceID sPhysical
ActiveSheet.Range("A1") = sPhysical
ActiveSheet.Range("A2") = iPriceID
ActiveSheet.Range("A3") = ""
ActiveSheet.Range("A4") = dBeginDate
GetPriceID sGasDaily
ActiveSheet.Range("A5") = sGasDaily
ActiveSheet.Range("A6") = iPriceID
ActiveSheet.Range("A8") = dBeginDate
Else
GetPriceID sGasDaily
ActiveSheet.Range("A2") = iPriceID
ActiveSheet.Range("A3") = ""
ActiveSheet.Range("A4") = dBeginDate
GetPriceID sPhysical
ActiveSheet.Range("A6") = iPriceID
ActiveSheet.Range("A8") = dBeginDate
End If
Next iSheet
Worksheets("FrontEnd").Activate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ExitHandler:
'Close all connections
If Not wspSQLServer Then
Set rs = Nothing
Set dbsSQLServer = Nothing
Set wspSQLServer = Nothing
End If
Exit Sub
ErrHandler:
MsgBox Error() & ", code = " & Err()
Resume ExitHandler
End Sub
Without puttting anyone completely out, can anyone look at this code and see or tell me or advise me, why it may be taking the data out of the database and placing it out of order within the excel sheet? thanks!!!
I know its long...sorry
Public SheetName(35) As String
Public iPriceID As Integer
Sub Run_Report()
Dim iNumSheets As Integer
Dim iCount As Integer
Dim wSheet As Worksheet
Dim rs As Recordset
Dim sSql As String
Dim dBeginDate As Date
Dim dEndDate As Date
Dim dBeginMonth As Date
Dim dEndMonth As Date
Dim sGasDaily As String
Dim sPhysical As String
Dim iRow As Integer
Dim iColumn As Integer
Dim iCounter As Integer
Dim sMonth As String
Dim sYear As String
Dim sEndMonth As String
Dim sEndYear As String
Dim bNew As Boolean
Dim bNewPriceID As Boolean
Dim iSheet As Integer
Dim sRegion1 As String
Dim sRegion2 As String
On Error GoTo ErrHandler
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
If login_db = False Then End
'Begin and End Date
dBeginDate = Worksheets("FrontEnd").Range("BeginDate")
dEndDate = Worksheets("FrontEnd").Range("EndDate")
'Begin and End Month
dBeginMonth = Worksheets("FrontEnd").Range("BeginMonth")
dEndMonth = Worksheets("FrontEnd").Range("EndMonth")
'Get total number of worksheets
iNumSheets = ActiveWorkbook.Sheets.Count
iCount = 1
'Assign Names of worksheets to array
For Each wSheet In Worksheets
SheetName(iCount) = wSheet.Name
iCount = iCount + 1
Next wSheet
'Routine to retrieve and populate data for all curves
For iSheet = 4 To iNumSheets
bNewPriceID = False
bNew = False
sGasDaily = Worksheets(SheetName(iSheet)).Range("A1")
sPhysical = Worksheets(SheetName(iSheet)).Range("A5")
sMonth = Format(dEndMonth, "mm")
sYear = Format(dEndMonth, "yyyy")
sSql = ""
sSql = "SELECT "
sSql = sSql & "PE2.ContractMonth, "
sSql = sSql & "PE2.Price, "
sSql = sSql & "PE2.PriceID, "
sSql = sSql & "PL2.PriceDesc, "
sSql = sSql & "PE2.DateOf "
sSql = sSql & "FROM "
sSql = sSql & "dbo.PriceExact_V PE2, "
sSql = sSql & "dbo.PriceLookup_V PL2 "
sSql = sSql & "WHERE "
sSql = sSql & "PL2.PriceID = PE2.PriceID AND PE2.SubID = "
sSql = sSql & "CASE "
sSql = sSql & "WHEN PL2.Pricetable = 'ELE' "
sSql = sSql & "THEN PE2.SubID ELSE 0 "
sSql = sSql & "END "
sSql = sSql & "AND PE2.DateOf BETWEEN '" & dBeginDate & "' AND '" & dEndDate & "'"
sSql = sSql & "AND PE2.ContractMonth BETWEEN '" & dBeginMonth & "' AND '" & dEndMonth & "'"
sSql = sSql & "AND PL2.PriceDesc IN ('" & sGasDaily & "','" & sPhysical & "')"
Set rs = dbsSQLServer.OpenRecordset(sSql, dbOpenSnapshot, dbSQLPassThrough)
If Not rs.EOF Then
rs.MoveLast
rs.MoveFirst
End If
Worksheets(SheetName(iSheet)).Select
Range("3:4,7:8").Select
Selection.ClearContents
Range("A1").Select
'Column Names
iColumn = 1
For iCounter = 0 To rs.Fields.Count - 4
Cells((iCounter + 3), iColumn) = "" & rs.Fields(iCounter).Name
Next iCounter
Do While Not rs.EOF
iColumn = iColumn + 1
'First Region
If Not bNewPriceID Then
For iRow = 3 To 4
sEndMonth = Format(Trim(rs(Cells(iRow, 1))), "mm")
sEndYear = Format(Trim(rs(Cells(iRow, 1))), "yyyy")
If iRow = 3 And sEndYear = Format(dBeginMonth, "yyyy") _
And sEndMonth = Format(dBeginMonth, "mm") And iColumn <> 2 Then
'Cells(3, iColumn) = "" & Trim(rs(Cells(3, 1)))
'Cells(4, iColumn) = "" & Trim(rs(Cells(4, 1)))
'Cells(5, iColumn) = "" & Trim(rs(Cells(5, 1)))
'Cells(6, iColumn) = "" & Trim(rs(Cells(6, 1)))
'rs.MoveNext
bNew = True
iColumn = 2
Exit For
End If
Cells(iRow, iColumn) = "" & Trim(rs(Cells(iRow, 1)))
Next iRow
End If
'Second Region
If bNew Then
bNewPriceID = True
For iRow = 3 To 4
On Error Resume Next
Cells(iRow + 4, iColumn) = "" & Trim(rs(Cells(iRow, 1)))
Next iRow
End If
rs.MoveNext
Loop
rs.Close
'check for alphabetical order
sRegion1 = Left$(sGasDaily, 1)
sRegion2 = Left$(sPhysical, 1)
If sRegion2 < sRegion1 Then
GetPriceID sPhysical
ActiveSheet.Range("A1") = sPhysical
ActiveSheet.Range("A2") = iPriceID
ActiveSheet.Range("A3") = ""
ActiveSheet.Range("A4") = dBeginDate
GetPriceID sGasDaily
ActiveSheet.Range("A5") = sGasDaily
ActiveSheet.Range("A6") = iPriceID
ActiveSheet.Range("A8") = dBeginDate
Else
GetPriceID sGasDaily
ActiveSheet.Range("A2") = iPriceID
ActiveSheet.Range("A3") = ""
ActiveSheet.Range("A4") = dBeginDate
GetPriceID sPhysical
ActiveSheet.Range("A6") = iPriceID
ActiveSheet.Range("A8") = dBeginDate
End If
Next iSheet
Worksheets("FrontEnd").Activate
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ExitHandler:
'Close all connections
If Not wspSQLServer Then
Set rs = Nothing
Set dbsSQLServer = Nothing
Set wspSQLServer = Nothing
End If
Exit Sub
ErrHandler:
MsgBox Error() & ", code = " & Err()
Resume ExitHandler
End Sub