通过代码更改连接string

我有9张连接到teradata中的不同表，每次我必须input我的用户名和密码刷新和获取新的数据集。 有人请指教如何编写一个VBA代码，可以更改每个连接的连接string，并刷新数据表。我是VBA的一个开山人，并没有线索在VBA

感谢Syam

Answer 1

这是我做的：我把以下单元格A2：B5数据源：数据库：

我把SQL放在单元格D2中。 我使用第1行来告诉我查询需要多长时间。 然后，我在页面的任何地方添加一个button。 然后我打电话给下面的代码。 它看起来很复杂，但function的核心全部在Get_Data_Teradata中。

Get_SQL函数只是简单地读取列D，直到find一个空白行，然后为SQL返回一大块文本。 你可以用硬编码的SQL语句replace它。

Pop_Col_Heads将结果中的列标题放在第1行中。请注意，我已经在Win 7上的Excel 2010中发现了一个Bug，其中每个Excel会话只能填充一次或两次列。 如果我退出并重新加载Excel，它会再次运行一次或两次。

Copy_Data_From_RDBMS将ADODBlogging集置于活动工作表中的范围内。 我不得不做一些调整来处理插入和更新，因为它们不返回任何行。

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 (eg insert) ActiveSheet.Range("E2").Offset(nRow - 1, 0).Value = "<no data returned>" End If rs.Close Set rs = Nothing End Function