G
Guest
Here is my complete code. I have fixed some things with some help from people
at work. I click to run it and the error is "type mismatch". Again, any help
would be greatly appreciated. Thanks
Option Explicit
Private mcnToDatabase As Connection
Private mwksResults As Excel.Worksheet
Private Const STATE_FIPS_COL = 0
Private Const COMMODITY_COLUMN = 1
Private Const PRACTICE_COL = 2
Private Const CS = "Provider=Microsoft.Jet.OLEDB.4.0;User
ID=Admin;Mode=Share Deny None;Jet OLEDB:Engine Type=4;Data Source="
Private Const CLIENT_TAB = "CLIENT"
Private Const ALT_TAB = "ALT1"
Public Sub Run(dbPath As String)
Dim lDataRow As Long
Dim lData As String
Dim GetAllData As Variant
Dim asData() As Long
ReDim asData(1, 3)
ConnectToDatabase dbPath
GetAllData = asData()
'Stuff in Main that opens Excel
For lDataRow = 0 To UBound(asData)
Main dbPath, asData(lDataRow, STATE_FIPS_COL), asData(lData,
COMMODITY_COLUMN), asData(lData, PRACTICE_COL)
'RunSolver
'Save as new workbook
Next lDataRow
End Sub
Private Sub ConnectToDatabase(dbPath As String)
'mcn = GetConnection
End Sub
Private Sub WriteToExcel(lExcelRow As Long, sStateFips As String, sCommodity
As String, sPracticeCode As String, wks As Excel.Worksheet)
'Get to correct Excel sheet
'Row = lExcelRow, Column = 1
'Set Cell value = sStateFIPs
'Row = lExcelRow, Column = 2
'Set Cell value = sCommodity
'Row = lExcelRow, Column = 3
'Set Cell value = sPracticeCode
End Sub
Private Function GetAllData() As String()
'Gets array of unique state FIPS codes
'Recordset = query of distinct state fips codes
End Function
Sub Main(dbPath As String, istate As Long, icommodity As Long, ipractice As
Long)
Dim ClientTab As String, AltTab As String, calc
Dim lngTemp As Long, strTemp As String
With application
.DisplayAlerts = False
.ScreenUpdating = False
calc = .Calculation
.Calculation = xlCalculationManual
End With
ClientTab = "CLIENT"
AltTab = "ALT1"
application.StatusBar = "Retrieving recordset from CDB..."
GetTable dbPath, istate, icommodity
GetTableState dbPath, istate, icommodity, ipractice
GetTableCounty dbPath, istate, icommodity, ipractice
'
'strTemp = Right(Left(ClientFiles, Len(ClientFiles) - 4), 2)
'With ThisWorkbook.Sheets("ExhibitA")
' .Activate
' strTemp = Application.WorksheetFunction.VLookup(Val(strTemp), _
' .Range("StateLookup"), 3, False)
' .Range("SubTitle") = "ACReS Retroactive Comparison - " & strTemp
'End With
Calculate
With application
.StatusBar = "Done."
.Calculation = calc
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Private Sub GetTable(dbPath As String, istate As Integer, icommodity As Long)
'Chris
Dim cn As New Connection, rs As Recordset, rngTemp As Range
Dim fff As Range
Sheets("WeatherLookup_input").Select
Range("A2:AE2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Sheets("CrossProduct").Select
Range("A2:AE2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Sheets("StateYield_input").Select
Range("A2:G2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Sheets("CountyYield").Select
Range("A10:AJ10").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Set rngTemp =
ThisWorkbook.Sheets("WeatherLookup_input").Range("weatherdatastart")
'TODO: Fix to mcn
cn.ConnectionString = CS & dbPath
cn.Open
Set rs = cn.Execute("Select [Year]*10+[DivNo],
[HistoricalDiv_Weather_1895-2003].*, 1, 1 from
[HistoricalDiv_Weather_1895-2003] where Year >= 1970 and fp =" & istate)
rngTemp.CopyFromRecordset rs
rngTemp.CurrentRegion.Name = "weatherdatarange"
Sheets("WeatherLookup").Select
Range("A2:AE2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("CrossProduct").Select
Range("A2").Select
ActiveSheet.Paste
Range("F2").Select
'ActiveCell.FormulaR1C1 = "=CountyYield!R5C[-2]*WeatherLookup_input!RC"
ActiveCell.FormulaR1C1 = _
"=IF(AND(Start!R17C[10]=-1,NOT(ISERROR(VLOOKUP(CrossProduct!RC1-10,weatherdatarange1,1,FALSE)))),VLOOKUP(CrossProduct!RC1-10,weatherdatarange1,R1C+5,FALSE),VLOOKUP(CrossProduct!RC1,weatherdatarange1,R1C+5,FALSE))"
Range("F2").Select
Selection.Copy
Range("F2:AC2").Select
ActiveSheet.Paste
Range("F2:AC2").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Range("AD2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-24]:RC[-13])"
Range("AE2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-13]:RC[-2])"
Range("AD2:AE2").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Range("A2:AE2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Set fff = Selection
fff.CurrentRegion.Name = "fffr"
Calculate
cn.Close
Set cn = Nothing
rs.Close
Set rs = Nothing
End Sub
Sub GetTableState(dbPath As String, istate As Integer, icommodity As Long,
ipractice As Integer)
Dim cn As New Connection, rs As Recordset, rngTemp As Range
Set rngTemp =
ThisWorkbook.Sheets("StateYield_input").Range("StateYield_input_start")
cn.ConnectionString = CS & dbPath
cn.Open
Set rs = cn.Execute("Select * from [stateyld] where Year >= 1970 and " &
"StFips = " & istate & " and CommCode = " & icommodity & " and PracCode = " &
ipractice)
rngTemp.CopyFromRecordset rs
rngTemp.CurrentRegion.Name = "styldrange"
cn.Close
Set cn = Nothing
End Sub
Sub GetTableCounty(dbPath As String, istate As Integer, icommodity As Long,
ipractice As Integer)
Dim cn As New Connection, rs As Recordset, rngTemp As Range
Dim maxlen As Integer
Dim myCount As Integer
Set rngTemp = ThisWorkbook.Sheets("CountyYield").Range("CountyYieldstart")
cn.ConnectionString = CS & dbPath
cn.Open
Set rs = cn.Execute("Select * from [cntyyld] where (Year >= 1970 and Year <=
2003) and StFips =" & istate & "and CommCode=" & icommodity & "and PracCode
= " & ipractice)
rngTemp.CopyFromRecordset rs
rngTemp.CurrentRegion.Name = "cntyyldrange"
Sheets("CountyYield").Select
Range("J9").Select
Range(Selection, Selection.End(xlDown)).Select
myCount = Selection.Count
Range("k9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-10],styldrange,7,FALSE)"
Range("L9").Select
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"
Range("M9").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-6],Div_Cnty_Lookup!R1C1:R3343C8,6,FALSE)"
Range("N9").Select
ActiveCell.FormulaR1C1 = "=RC[-13]*10+RC[-1]"
Range("O9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],fffr,30,FALSE)"
Range("p9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],fffr,31,FALSE)"
Range("q9").Select
ActiveCell.FormulaR1C1 =
"=R2C7+R2C8*RC[-2]+R2C9*RC[-1]+R2C10*RC[-2]*RC[-2]+R2C11*RC[-1]*RC[-1]"
Range("k9:AH9").Select
Selection.Copy
Range("K9:AH9", "AH" & myCount + 8).Select
ActiveSheet.Paste
Range("R7").Select
ActiveCell.FormulaR1C1 = "=SUM(R[+2]C[0]:R[" & myCount + 1 & "]C[0])"
Selection.Copy
Range("R7:AH7").Select
ActiveSheet.Paste
Range("AI7").Select
ActiveCell.FormulaR1C1 = myCount
Range("L2").Select
ActiveCell.FormulaR1C1 = "=CORREL(R[+7]C[0]:R[" & myCount + 6 &
"]C[0],R[+7]C[+5]:R[" & myCount + 6 & "]C[+5])"
cn.Close
Set cn = Nothing
End Sub
at work. I click to run it and the error is "type mismatch". Again, any help
would be greatly appreciated. Thanks
Option Explicit
Private mcnToDatabase As Connection
Private mwksResults As Excel.Worksheet
Private Const STATE_FIPS_COL = 0
Private Const COMMODITY_COLUMN = 1
Private Const PRACTICE_COL = 2
Private Const CS = "Provider=Microsoft.Jet.OLEDB.4.0;User
ID=Admin;Mode=Share Deny None;Jet OLEDB:Engine Type=4;Data Source="
Private Const CLIENT_TAB = "CLIENT"
Private Const ALT_TAB = "ALT1"
Public Sub Run(dbPath As String)
Dim lDataRow As Long
Dim lData As String
Dim GetAllData As Variant
Dim asData() As Long
ReDim asData(1, 3)
ConnectToDatabase dbPath
GetAllData = asData()
'Stuff in Main that opens Excel
For lDataRow = 0 To UBound(asData)
Main dbPath, asData(lDataRow, STATE_FIPS_COL), asData(lData,
COMMODITY_COLUMN), asData(lData, PRACTICE_COL)
'RunSolver
'Save as new workbook
Next lDataRow
End Sub
Private Sub ConnectToDatabase(dbPath As String)
'mcn = GetConnection
End Sub
Private Sub WriteToExcel(lExcelRow As Long, sStateFips As String, sCommodity
As String, sPracticeCode As String, wks As Excel.Worksheet)
'Get to correct Excel sheet
'Row = lExcelRow, Column = 1
'Set Cell value = sStateFIPs
'Row = lExcelRow, Column = 2
'Set Cell value = sCommodity
'Row = lExcelRow, Column = 3
'Set Cell value = sPracticeCode
End Sub
Private Function GetAllData() As String()
'Gets array of unique state FIPS codes
'Recordset = query of distinct state fips codes
End Function
Sub Main(dbPath As String, istate As Long, icommodity As Long, ipractice As
Long)
Dim ClientTab As String, AltTab As String, calc
Dim lngTemp As Long, strTemp As String
With application
.DisplayAlerts = False
.ScreenUpdating = False
calc = .Calculation
.Calculation = xlCalculationManual
End With
ClientTab = "CLIENT"
AltTab = "ALT1"
application.StatusBar = "Retrieving recordset from CDB..."
GetTable dbPath, istate, icommodity
GetTableState dbPath, istate, icommodity, ipractice
GetTableCounty dbPath, istate, icommodity, ipractice
'
'strTemp = Right(Left(ClientFiles, Len(ClientFiles) - 4), 2)
'With ThisWorkbook.Sheets("ExhibitA")
' .Activate
' strTemp = Application.WorksheetFunction.VLookup(Val(strTemp), _
' .Range("StateLookup"), 3, False)
' .Range("SubTitle") = "ACReS Retroactive Comparison - " & strTemp
'End With
Calculate
With application
.StatusBar = "Done."
.Calculation = calc
.ScreenUpdating = True
.DisplayAlerts = True
End With
End Sub
Private Sub GetTable(dbPath As String, istate As Integer, icommodity As Long)
'Chris
Dim cn As New Connection, rs As Recordset, rngTemp As Range
Dim fff As Range
Sheets("WeatherLookup_input").Select
Range("A2:AE2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Sheets("CrossProduct").Select
Range("A2:AE2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Sheets("StateYield_input").Select
Range("A2:G2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Sheets("CountyYield").Select
Range("A10:AJ10").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.ClearContents
Set rngTemp =
ThisWorkbook.Sheets("WeatherLookup_input").Range("weatherdatastart")
'TODO: Fix to mcn
cn.ConnectionString = CS & dbPath
cn.Open
Set rs = cn.Execute("Select [Year]*10+[DivNo],
[HistoricalDiv_Weather_1895-2003].*, 1, 1 from
[HistoricalDiv_Weather_1895-2003] where Year >= 1970 and fp =" & istate)
rngTemp.CopyFromRecordset rs
rngTemp.CurrentRegion.Name = "weatherdatarange"
Sheets("WeatherLookup").Select
Range("A2:AE2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("CrossProduct").Select
Range("A2").Select
ActiveSheet.Paste
Range("F2").Select
'ActiveCell.FormulaR1C1 = "=CountyYield!R5C[-2]*WeatherLookup_input!RC"
ActiveCell.FormulaR1C1 = _
"=IF(AND(Start!R17C[10]=-1,NOT(ISERROR(VLOOKUP(CrossProduct!RC1-10,weatherdatarange1,1,FALSE)))),VLOOKUP(CrossProduct!RC1-10,weatherdatarange1,R1C+5,FALSE),VLOOKUP(CrossProduct!RC1,weatherdatarange1,R1C+5,FALSE))"
Range("F2").Select
Selection.Copy
Range("F2:AC2").Select
ActiveSheet.Paste
Range("F2:AC2").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Range("AD2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-24]:RC[-13])"
Range("AE2").Select
ActiveCell.FormulaR1C1 = "=SUM(RC[-13]:RC[-2])"
Range("AD2:AE2").Select
Selection.Copy
Range(Selection, Selection.End(xlDown)).Select
ActiveSheet.Paste
Range("A2:AE2").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Set fff = Selection
fff.CurrentRegion.Name = "fffr"
Calculate
cn.Close
Set cn = Nothing
rs.Close
Set rs = Nothing
End Sub
Sub GetTableState(dbPath As String, istate As Integer, icommodity As Long,
ipractice As Integer)
Dim cn As New Connection, rs As Recordset, rngTemp As Range
Set rngTemp =
ThisWorkbook.Sheets("StateYield_input").Range("StateYield_input_start")
cn.ConnectionString = CS & dbPath
cn.Open
Set rs = cn.Execute("Select * from [stateyld] where Year >= 1970 and " &
"StFips = " & istate & " and CommCode = " & icommodity & " and PracCode = " &
ipractice)
rngTemp.CopyFromRecordset rs
rngTemp.CurrentRegion.Name = "styldrange"
cn.Close
Set cn = Nothing
End Sub
Sub GetTableCounty(dbPath As String, istate As Integer, icommodity As Long,
ipractice As Integer)
Dim cn As New Connection, rs As Recordset, rngTemp As Range
Dim maxlen As Integer
Dim myCount As Integer
Set rngTemp = ThisWorkbook.Sheets("CountyYield").Range("CountyYieldstart")
cn.ConnectionString = CS & dbPath
cn.Open
Set rs = cn.Execute("Select * from [cntyyld] where (Year >= 1970 and Year <=
2003) and StFips =" & istate & "and CommCode=" & icommodity & "and PracCode
= " & ipractice)
rngTemp.CopyFromRecordset rs
rngTemp.CurrentRegion.Name = "cntyyldrange"
Sheets("CountyYield").Select
Range("J9").Select
Range(Selection, Selection.End(xlDown)).Select
myCount = Selection.Count
Range("k9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-10],styldrange,7,FALSE)"
Range("L9").Select
ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-2]"
Range("M9").Select
ActiveCell.FormulaR1C1 = _
"=VLOOKUP(RC[-6],Div_Cnty_Lookup!R1C1:R3343C8,6,FALSE)"
Range("N9").Select
ActiveCell.FormulaR1C1 = "=RC[-13]*10+RC[-1]"
Range("O9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-1],fffr,30,FALSE)"
Range("p9").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-2],fffr,31,FALSE)"
Range("q9").Select
ActiveCell.FormulaR1C1 =
"=R2C7+R2C8*RC[-2]+R2C9*RC[-1]+R2C10*RC[-2]*RC[-2]+R2C11*RC[-1]*RC[-1]"
Range("k9:AH9").Select
Selection.Copy
Range("K9:AH9", "AH" & myCount + 8).Select
ActiveSheet.Paste
Range("R7").Select
ActiveCell.FormulaR1C1 = "=SUM(R[+2]C[0]:R[" & myCount + 1 & "]C[0])"
Selection.Copy
Range("R7:AH7").Select
ActiveSheet.Paste
Range("AI7").Select
ActiveCell.FormulaR1C1 = myCount
Range("L2").Select
ActiveCell.FormulaR1C1 = "=CORREL(R[+7]C[0]:R[" & myCount + 6 &
"]C[0],R[+7]C[+5]:R[" & myCount + 6 & "]C[+5])"
cn.Close
Set cn = Nothing
End Sub