Change Connection String via code [closed] - vba

Question

Closed. This question does not meet Stack Overflow guidelines. It is not currently accepting answers.
Questions asking for code must demonstrate a minimal understanding of the problem being solved. Include attempted solutions, why they didn't work, and the expected results. See also: Stack Overflow question checklist
Closed 9 years ago.
Improve this question
I have 9 sheets that connect to different tables in teradata, each time i have to enter my user name and password to refresh and get new set of data. could someone please advice how do i write a VBA code that could change the connection string for each connection and refresh the data table.I am a begginner in VBA and have no clue in codding in VBA
Thanks
Syam

Answer 1

Here is what I do: I put the following in cells A2:B5
Data Source:
Database:
I put the SQL in cell D2. I use Row 1 for telling me how long the query takes. Then, I add a button anywhere on the page. Then I call the code below. It looks complicated, but the core of the functionality is all in Get_Data_Teradata.
The Get_SQL Function simply reads down column D until it finds a blank row and then returns a big block of text for the SQL. You could replace this with a hardcoded SQL statement.
Pop_Col_Heads puts the column headings from the result in Row 1. Note, that I have discovered a Bug in Excel 2010 on Win 7 where I can only populate columns once or twice per Excel session. If I quit and load Excel again, it works another once or twice.
Copy_Data_From_RDBMS places the ADODB RecordSet into a range in the active sheet. I had to do some tweaks to handle inserts and updates because they don't return any rows.
Sub Get_Data_Teradata()
'Supports Multi Query
Dim cn As ADODB.Connection
Dim sConnect As String
Set cn = New ADODB.Connection
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
Dim cmdSQLData As ADODB.Command
Set cmdSQLData = New ADODB.Command
Dim sQueries() As String
sConnect = "Persist Security Info=True; Session Mode=ANSI; " & _
"Data Source=" & ActiveSheet.Range("B2").Value & ";" & _
"Database=" & ActiveSheet.Range("B3").Value & ";" & _
"User ID=" & ActiveSheet.Range("B4").Value & ";" & _
"Password=" & ActiveSheet.Range("B5").Value & ";"
sQueries = Get_SQL(ActiveSheet.Range("D2:D9999"))
nRow = 1 'initialize to start at the top of the page
For i = 0 To UBound(sQueries) - 1
cn.Open sConnect
Set cmdSQLData.ActiveConnection = cn
cmdSQLData.CommandText = sQueries(i) 'TELL VBA TO LOAD THE QUERY INTO TERADATA
cmdSQLData.CommandType = adCmdText
cmdSQLData.CommandTimeout = 0
Set rs = cmdSQLData.Execute()
Call Pop_Col_Heads(rs, nRow)
nRow = Copy_Data_From_RDBMS(rs, nRow)
cn.Close
Next i
End Sub
Dim a As Long
Dim i As Long
Dim nIndex As Long
Dim sSQL() As String
Function Get_SQL(oRange As Object) As String()
'First figure out how many rows the SQL statement is
a = 0
For Each cCell In oRange
a = a + 1
If cCell.Value = "" Then
a = a - 1
Exit For
End If
Next cCell
'Num rows = a now
'Step through and parse into array
i = 0
nIndex = 0
ReDim Preserve sSQL(1)
For Each cCell In oRange
i = i + 1
If i > a Then
Exit For
ElseIf cCell.Value = "<Multi>" Then
nIndex = nIndex + 1
ReDim Preserve sSQL(nIndex + 1)
Else
sSQL(nIndex) = sSQL(nIndex) & To_Text(cCell.Value) & " "
End If
Next cCell
Get_SQL = sSQL
End Function
Sub Pop_Col_Heads(rs As Object, nRow As Long)
Dim rHeads As Range
Dim fFields As Field
Dim nCol As Integer
nCol = 0
If nRow = 1 Then
ActiveSheet.Range("E1:ZZ1").ClearContents
End If
Set rHeads = ActiveSheet.Range("E1").Offset(nRow - 1, 0)
Do While nCol < rs.Fields.Count
sTemp = rs.Fields(nCol).Name
rHeads.Cells(nRow, nCol + 1).Value = rs.Fields(nCol).Name
ActiveSheet.Calculate
rHeads.Cells(nRow, nCol + 1).Value = sTemp
nCol = nCol + 1
rHeads.WrapText = True
rHeads.VerticalAlignment = xlVAlignTop
Loop
End Sub
Function Copy_Data_From_RDBMS(rs As Object, nRow As Long) As Long
'Supports Multi Query
If nRow = 1 Then
x = Get_Last_Row_Find(ActiveSheet.Range("E1:ZZ64000"))
ActiveSheet.Range("E2:ZZ" & x).ClearContents
End If
On Error Resume Next
rs.MoveFirst
On Error GoTo 0
If Not rs.EOF Then
ActiveSheet.Range("E2").Offset(nRow - 1, 0).CopyFromRecordset rs
x = Get_Last_Row_Find(ActiveSheet.Range("E1:ZZ64000"))
Copy_Data_From_RDBMS = x + 1
ActiveSheet.Range("E2:ZZ" & x).Offset(nRow - 1, 0).WrapText = False
Else 'no results (e.g. insert)
ActiveSheet.Range("E2").Offset(nRow - 1, 0).Value = "<no data returned>"
End If
rs.Close
Set rs = Nothing
End Function