R
rbrig
Hello all,
I'm new to Excel VBA programming but not new to programming. I've been asked to fix an Excel template that creates a querytable via ODBC and its parameters on a specified worksheet. Since I might be linking to a worksheet that already has a querytable on it I decided to take it one step further. I want to read the parameter names, values and locations from the querytable and display them in the template. I'm using the SourceRange property of the Parameter to find the address and Row/Col to find the value. It works as long as the querytable and parameters are on the same worksheet or if the querytable is on Sheet1 and the parameters are on Sheet1 or Sheet2. If any parameteris on Sheet3 the SourceRange property is undefined for that parameter (weird). Any help would be greatly appreciated. Code below.
Sub CreateQueryTable()
Dim iQueryTableName, iWorkbook, iworksheet, iRng As Variant
Dim oWB As Workbook, oWS As Worksheet, pWS As Worksheet
Dim ODBC_CONNECTION_STRING As String
Dim strQuery As String
Dim oRange As Range
Dim Param As Parameter
Dim i As Integer, pName As String, ptype As String, pSheet As String, pRange As String
Dim pSheet_old, pName_old As String
Dim qData As QueryTable
iQueryTableName = Range("Query_Table_Name").Value
iWorkbook = Range("Workbook").Value
iworksheet = Range("Worksheet").Value
iRng = Range("Range").Value
On Error GoTo W:
Set oWB = Workbooks(iWorkbook)
On Error GoTo S:
Set oWS = Workbooks(iWorkbook).Sheets(iworksheet)
'Search the specified worksheet for the query table name
'If it's not there create it
For Each qt In oWS.QueryTables
If qt.Name = iQueryTableName Then
'Instead of erasing the previous querytable I'm going to
'update it instead using the CommandText method
On Error Resume Next
'If the Query Table exists just clear the contents
oWS.QueryTables(iQueryTableName).ResultRange.ClearContents
Set qData = qt
Exit For
' Else
' 'If you want to create a new query table name you will be stuck
'with the old one on the same spreadsheet. There's no way to distinquish a previous
'query table name from another query table on the same spreadsheet.
'
' 'erase the previous query results on worksheet
' On Error Resume Next
' oWS.Range(qt.Name).Clear
'
' 'delete the querytable range name on worksheet
' On Error Resume Next
' oWS.Names(qt.Name).Delete
'
' 'delete the querytable object
' On Error Resume Next
' qt.Delete
End If
Next qt
'If query table isn't there then create it otherwise update the SQL and delete the parameters
If qData Is Nothing Then
On Error GoTo W:
ODBC_CONNECTION_STRING = Range("ODBC_CONNECTION_STRING").Value
On Error GoTo r:
Set oRange = oWS.Range(iRng)
On Error GoTo Q:
strQuery = Range("SQL_Text").Value
Set qData = oWS.QueryTables.Add(Connection:=ODBC_CONNECTION_STRING, Destination:=oRange, Sql:=strQuery)
Else
On Error GoTo Q:
qData.CommandText = Range("SQL_Text").Value
qData.Parameters.Delete
End If
With qData
i = 1
pName = Range("Parameter_Name").Offset(i, 0).Value
Do While pName <> ""
ptype = Range("Parameter_Name").Offset(i, 1).Value
pSheet = Range("Parameter_Name").Offset(i, 2).Value
pRange = Range("Parameter_Name").Offset(i, 3).Value
' If Param Is Nothing Or pName <> pName_old Then
Set Param = .Parameters.Add(pName, GetTypeOf(ptype))
' End If
' If pWS Is Nothing Or pSheet <> pSheet_old Then
Set pWS = Workbooks(iWorkbook).Sheets(pSheet)
' End If
Param.SetParam xlRange, pWS.Range(pRange)
i = i + 1
' pName_old = pName
pName = Range("Parameter_Name").Offset(i, 0).Value
' pSheet_old = pSheet
Set Param = Nothing
Set pWS = Nothing
Loop
.Name = iQueryTableName
.BackgroundQuery = False
.RefreshOnFileOpen = Sheets("Options").Range("RefreshOnFileOpen").Value
.SavePassword = Sheets("Options").Range("SavePassword").Value
.SaveData = Sheets("Options").Range("SaveData").Value
.FieldNames = Sheets("Options").Range("FieldNames").Value
.PreserveFormatting = Sheets("Options").Range("PreserveFormatting").Value
.AdjustColumnWidth = Sheets("Options").Range("AdjustColumnWidth").Value
.RowNumbers = Sheets("Options").Range("RowNumbers").Value
.PreserveColumnInfo = Sheets("Options").Range("PreserveColumnInfo").Value
.FillAdjacentFormulas = Sheets("Options").Range("FillAdjacentFormulas").Value
.HasAutoFormat = Sheets("Options").Range("HasAutoFormat").Value
.RefreshStyle = GetRefreshStyle(Sheets("Options").Range("RefreshStyle").Value)
.Refresh
Range("Query_Table_Name").Value = .Name
End With
Set oWS = Nothing
Set oRange = Nothing
Set Param = Nothing
Set oWB = Nothing
Set pWS = Nothing
Set qData = Nothing
' cmdParameters.Visible = True
' cmdSQLString.Visible = True
' cmdResetParameters.Visible = True
Exit Sub
'Find the parameters
Private Sub cmdParameters_Click()
Dim i, j As Integer
Dim qtp As Parameter
Dim ptype, pSheet, pName As String
Dim iQueryTableName, iWorkbook, iworksheet, iRng As String
Dim oWB As Workbook, oWS As Worksheet, tWS As Worksheet
Dim r As Range
On Error GoTo ERROR:
iQueryTableName = Range("Query_Table_Name").Value
iWorkbook = Range("Workbook").Value
iworksheet = Range("Worksheet").Value
'Get the WorkBook that the query table is contained in
Set oWB = Workbooks(iWorkbook)
'Get the WorkSheet that the query table is on
Set oWS = Workbooks(iWorkbook).Sheets(iworksheet)
'Clear parameter range
Range(Range("Parameter_Name").Offset(1, 0).Address, Range("ParameterNameEnd").Address).ClearContents
i = 1
For Each qtp In oWS.QueryTables(iQueryTableName).Parameters
Select Case qtp.DataType
Case xlParamTypeBigInt
ptype = "xlParamTypeBigInt"
Case xlParamTypeBinary
ptype = "xlParamTypeBinary"
Case xlParamTypeBit
ptype = "xlParamTypeBit"
Case xlParamTypeChar
ptype = "xlParamTypeChar"
Case xlParamTypeDate
ptype = "xlParamTypeDate"
Case xlParamTypeDecimal
ptype = "xlParamTypeDecimal"
Case xlParamTypeDouble
ptype = "xlParamTypeDouble"
Case xlParamTypeFloat
ptype = "xlParamTypeFloat"
Case xlParamTypeInteger
ptype = "xlParamTypeInteger"
Case xlParamTypeLongVarBinary
ptype = "xlParamTypeLongVarBinary"
Case xlParamTypeLongVarChar
ptype = "xlParamTypeLongVarChar"
Case xlParamTypeNumeric
ptype = "xlParamTypeNumeric"
Case xlParamTypeReal
ptype = "xlParamTypeReal"
Case xlParamTypeSmallInt
ptype = "xlParamTypeSmallInt"
Case xlParamTypeTime
ptype = "xlParamTypeTime"
Case xlParamTypeTimestamp
ptype = "xlParamTypeTimestamp"
Case xlParamTypeTinyInt
ptype = "xlParamTypeTinyInt"
Case xlParamTypeUnknown
ptype = "xlParamTypeUnknown"
Case xlParamTypeVarBinary
ptype = "xlParamTypeVarBinary"
Case xlParamTypeVarChar
ptype = "xlParamTypeVarChar"
Case xlParamTypeWChar
ptype = "xlParamTypeWChar"
Case Else
ptype = "UNKNOWN"
End Select
'From the Query Table get the range object
Set r = oWS.QueryTables(iQueryTableName).Parameters(i).SourceRange
Set tWS = Workbooks(iWorkbook).Sheets(r.Worksheet.CodeName)
Set tWS = Workbooks(iWorkbook).Sheets(r.Worksheet.CodeName)
'Parameter Name
Range("Parameter_Name").Offset(i, 0).Value = qtp.Name
'Parameter Type
Range("Parameter_Name").Offset(i, 1).Value = ptype
'Worksheet
Range("Parameter_Name").Offset(i, 2).Value = r.Worksheet.CodeName
'Cell Location
Range("Parameter_Name").Offset(i, 3).Value = tWS.Cells(r.Row, r.Column).Address
'Parameter Value
Range("Parameter_Name").Offset(i, 4).Value = tWS.Cells(r.Row, r.Column).Value
'Gray Background
Range("Parameter_Name").Offset(i, 4).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
i = i + 1
' ActiveCell.Offset(1, 0).EntireRow.Insert
' ActiveCell.EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
Set r = Nothing
Set tWS = Nothing
Next qtp
Set r = Nothing
Set oWB = Nothing
Set oWS = Nothing
Set qtp = Nothing
Exit Sub
ERROR:
Set r = Nothing
Set oWB = Nothing
Set oWS = Nothing
Set qtp = Nothing
MsgBox ("Parameter Not Found. Please check Workbook/Worksheet/Query table name given for accuracy.")
Exit Sub
End Sub
EggHeadCafe.com - .NET Developer Portal of Choice
http://www.eggheadcafe.com
I'm new to Excel VBA programming but not new to programming. I've been asked to fix an Excel template that creates a querytable via ODBC and its parameters on a specified worksheet. Since I might be linking to a worksheet that already has a querytable on it I decided to take it one step further. I want to read the parameter names, values and locations from the querytable and display them in the template. I'm using the SourceRange property of the Parameter to find the address and Row/Col to find the value. It works as long as the querytable and parameters are on the same worksheet or if the querytable is on Sheet1 and the parameters are on Sheet1 or Sheet2. If any parameteris on Sheet3 the SourceRange property is undefined for that parameter (weird). Any help would be greatly appreciated. Code below.
Sub CreateQueryTable()
Dim iQueryTableName, iWorkbook, iworksheet, iRng As Variant
Dim oWB As Workbook, oWS As Worksheet, pWS As Worksheet
Dim ODBC_CONNECTION_STRING As String
Dim strQuery As String
Dim oRange As Range
Dim Param As Parameter
Dim i As Integer, pName As String, ptype As String, pSheet As String, pRange As String
Dim pSheet_old, pName_old As String
Dim qData As QueryTable
iQueryTableName = Range("Query_Table_Name").Value
iWorkbook = Range("Workbook").Value
iworksheet = Range("Worksheet").Value
iRng = Range("Range").Value
On Error GoTo W:
Set oWB = Workbooks(iWorkbook)
On Error GoTo S:
Set oWS = Workbooks(iWorkbook).Sheets(iworksheet)
'Search the specified worksheet for the query table name
'If it's not there create it
For Each qt In oWS.QueryTables
If qt.Name = iQueryTableName Then
'Instead of erasing the previous querytable I'm going to
'update it instead using the CommandText method
On Error Resume Next
'If the Query Table exists just clear the contents
oWS.QueryTables(iQueryTableName).ResultRange.ClearContents
Set qData = qt
Exit For
' Else
' 'If you want to create a new query table name you will be stuck
'with the old one on the same spreadsheet. There's no way to distinquish a previous
'query table name from another query table on the same spreadsheet.
'
' 'erase the previous query results on worksheet
' On Error Resume Next
' oWS.Range(qt.Name).Clear
'
' 'delete the querytable range name on worksheet
' On Error Resume Next
' oWS.Names(qt.Name).Delete
'
' 'delete the querytable object
' On Error Resume Next
' qt.Delete
End If
Next qt
'If query table isn't there then create it otherwise update the SQL and delete the parameters
If qData Is Nothing Then
On Error GoTo W:
ODBC_CONNECTION_STRING = Range("ODBC_CONNECTION_STRING").Value
On Error GoTo r:
Set oRange = oWS.Range(iRng)
On Error GoTo Q:
strQuery = Range("SQL_Text").Value
Set qData = oWS.QueryTables.Add(Connection:=ODBC_CONNECTION_STRING, Destination:=oRange, Sql:=strQuery)
Else
On Error GoTo Q:
qData.CommandText = Range("SQL_Text").Value
qData.Parameters.Delete
End If
With qData
i = 1
pName = Range("Parameter_Name").Offset(i, 0).Value
Do While pName <> ""
ptype = Range("Parameter_Name").Offset(i, 1).Value
pSheet = Range("Parameter_Name").Offset(i, 2).Value
pRange = Range("Parameter_Name").Offset(i, 3).Value
' If Param Is Nothing Or pName <> pName_old Then
Set Param = .Parameters.Add(pName, GetTypeOf(ptype))
' End If
' If pWS Is Nothing Or pSheet <> pSheet_old Then
Set pWS = Workbooks(iWorkbook).Sheets(pSheet)
' End If
Param.SetParam xlRange, pWS.Range(pRange)
i = i + 1
' pName_old = pName
pName = Range("Parameter_Name").Offset(i, 0).Value
' pSheet_old = pSheet
Set Param = Nothing
Set pWS = Nothing
Loop
.Name = iQueryTableName
.BackgroundQuery = False
.RefreshOnFileOpen = Sheets("Options").Range("RefreshOnFileOpen").Value
.SavePassword = Sheets("Options").Range("SavePassword").Value
.SaveData = Sheets("Options").Range("SaveData").Value
.FieldNames = Sheets("Options").Range("FieldNames").Value
.PreserveFormatting = Sheets("Options").Range("PreserveFormatting").Value
.AdjustColumnWidth = Sheets("Options").Range("AdjustColumnWidth").Value
.RowNumbers = Sheets("Options").Range("RowNumbers").Value
.PreserveColumnInfo = Sheets("Options").Range("PreserveColumnInfo").Value
.FillAdjacentFormulas = Sheets("Options").Range("FillAdjacentFormulas").Value
.HasAutoFormat = Sheets("Options").Range("HasAutoFormat").Value
.RefreshStyle = GetRefreshStyle(Sheets("Options").Range("RefreshStyle").Value)
.Refresh
Range("Query_Table_Name").Value = .Name
End With
Set oWS = Nothing
Set oRange = Nothing
Set Param = Nothing
Set oWB = Nothing
Set pWS = Nothing
Set qData = Nothing
' cmdParameters.Visible = True
' cmdSQLString.Visible = True
' cmdResetParameters.Visible = True
Exit Sub
'Find the parameters
Private Sub cmdParameters_Click()
Dim i, j As Integer
Dim qtp As Parameter
Dim ptype, pSheet, pName As String
Dim iQueryTableName, iWorkbook, iworksheet, iRng As String
Dim oWB As Workbook, oWS As Worksheet, tWS As Worksheet
Dim r As Range
On Error GoTo ERROR:
iQueryTableName = Range("Query_Table_Name").Value
iWorkbook = Range("Workbook").Value
iworksheet = Range("Worksheet").Value
'Get the WorkBook that the query table is contained in
Set oWB = Workbooks(iWorkbook)
'Get the WorkSheet that the query table is on
Set oWS = Workbooks(iWorkbook).Sheets(iworksheet)
'Clear parameter range
Range(Range("Parameter_Name").Offset(1, 0).Address, Range("ParameterNameEnd").Address).ClearContents
i = 1
For Each qtp In oWS.QueryTables(iQueryTableName).Parameters
Select Case qtp.DataType
Case xlParamTypeBigInt
ptype = "xlParamTypeBigInt"
Case xlParamTypeBinary
ptype = "xlParamTypeBinary"
Case xlParamTypeBit
ptype = "xlParamTypeBit"
Case xlParamTypeChar
ptype = "xlParamTypeChar"
Case xlParamTypeDate
ptype = "xlParamTypeDate"
Case xlParamTypeDecimal
ptype = "xlParamTypeDecimal"
Case xlParamTypeDouble
ptype = "xlParamTypeDouble"
Case xlParamTypeFloat
ptype = "xlParamTypeFloat"
Case xlParamTypeInteger
ptype = "xlParamTypeInteger"
Case xlParamTypeLongVarBinary
ptype = "xlParamTypeLongVarBinary"
Case xlParamTypeLongVarChar
ptype = "xlParamTypeLongVarChar"
Case xlParamTypeNumeric
ptype = "xlParamTypeNumeric"
Case xlParamTypeReal
ptype = "xlParamTypeReal"
Case xlParamTypeSmallInt
ptype = "xlParamTypeSmallInt"
Case xlParamTypeTime
ptype = "xlParamTypeTime"
Case xlParamTypeTimestamp
ptype = "xlParamTypeTimestamp"
Case xlParamTypeTinyInt
ptype = "xlParamTypeTinyInt"
Case xlParamTypeUnknown
ptype = "xlParamTypeUnknown"
Case xlParamTypeVarBinary
ptype = "xlParamTypeVarBinary"
Case xlParamTypeVarChar
ptype = "xlParamTypeVarChar"
Case xlParamTypeWChar
ptype = "xlParamTypeWChar"
Case Else
ptype = "UNKNOWN"
End Select
'From the Query Table get the range object
Set r = oWS.QueryTables(iQueryTableName).Parameters(i).SourceRange
Set tWS = Workbooks(iWorkbook).Sheets(r.Worksheet.CodeName)
Set tWS = Workbooks(iWorkbook).Sheets(r.Worksheet.CodeName)
'Parameter Name
Range("Parameter_Name").Offset(i, 0).Value = qtp.Name
'Parameter Type
Range("Parameter_Name").Offset(i, 1).Value = ptype
'Worksheet
Range("Parameter_Name").Offset(i, 2).Value = r.Worksheet.CodeName
'Cell Location
Range("Parameter_Name").Offset(i, 3).Value = tWS.Cells(r.Row, r.Column).Address
'Parameter Value
Range("Parameter_Name").Offset(i, 4).Value = tWS.Cells(r.Row, r.Column).Value
'Gray Background
Range("Parameter_Name").Offset(i, 4).Select
With Selection.Interior
.ColorIndex = 15
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
End With
i = i + 1
' ActiveCell.Offset(1, 0).EntireRow.Insert
' ActiveCell.EntireRow.Copy ActiveCell.Offset(1, 0).EntireRow
Set r = Nothing
Set tWS = Nothing
Next qtp
Set r = Nothing
Set oWB = Nothing
Set oWS = Nothing
Set qtp = Nothing
Exit Sub
ERROR:
Set r = Nothing
Set oWB = Nothing
Set oWS = Nothing
Set qtp = Nothing
MsgBox ("Parameter Not Found. Please check Workbook/Worksheet/Query table name given for accuracy.")
Exit Sub
End Sub
EggHeadCafe.com - .NET Developer Portal of Choice
http://www.eggheadcafe.com