How to delete or hide the password entry to access the data of a server with SQL Server from the VBA or Excel macro?

Question

I’m running a database migration service from a server with SQL Server in a company, but requested that I broker the migration in Excel, because they want so in this first phase to advance some treatments in spreadsheet.

I have no experience with SQL Server, but rather with Excel advanced and VBA, and with the assistance of a technician SQL Server basic way I created a macro and then adapted to how it is presented below; and it worked in this first test I did.

   For i = 1 To 3

   Select Case i

      Case 1
         Sheets("Plan1").Select
         N = "BD1"

      Case 2
         Sheets("Plan3").Select
         N = "BD2"

      Case 3
         Sheets("Plan5").Select
         N = "BD3"

   End Select

   With ActiveSheet.ListObjects.Add(SourceType:=0, Source:=Array( _
        "OLEDB;Provider=SQLOLEDB.1;Persist Security Info=True;User ID=sa;Data Source=10.0.0.5\sqlexpress;Use Procedure for Prepare=1;Auto Trans", _
        "late=True;Packet Size=4096;Workstation ID=LABORATORIO;Use Encryption for Data=False;Tag with column collation when possible=Fals", "e;Initial Catalog=Dados"), Destination:=Range("$A$1")).QueryTable
        .CommandType = xlCmdTable
        .CommandText = Array("""Dados"".""dbo""." & N & "")
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
        .SourceConnectionFile = _
        "C:\10.0.0.5_sqlexpress Dados " & N & ".odc"
        .ListObject.DisplayName = _
        "Tabela__10.0.0.5_sqlexpress_Dados_" & N
        .Refresh BackgroundQuery:=False
    End With

    Cells.Select

    Selection.Copy

    Select Case i

       Case 1
          Sheets("Plan2").Select

       Case 2
          Sheets("Plan4").Select

       Case 3
          Sheets("Plan6").Select
    End Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

   Range("A1").Select

Next i

In Plan1 the first data is opened perfectly, and a copy of them is made to Plan2 pasting everything as "values"; for the other two occurs the same, only it is Plan3 with Plan 4 and then Plan5 with Plan6.

It’s an initial test, so it stayed that way, I’ll improve once I get what I need.

Even tabs get the data the way the customer wants it. My problem is that this data is from a system that will be disabled is are more than 400 tables (not typed wrong not) to migrate.

As it stands, in each "loop" the password is requested to access the database.

I could not find how to put via macro or VBA this password so that everything is done automatically, without interruption (typing the password in a popup).

Can anyone help me? I thank you in advance.

Answer 1

Friend see if the function below suits you:

Sub SQLConnect(servername As String, dbname As String, tablename As String, uname As String, pword As String, sheetname as String)

'******************************************************
' Login no Servidor
'******************************************************
Dim cn As ADODB.Connection
Set cn = New ADODB.Connection

' Teste 1 - Usando conexão direta:    
On Error GoTo ErrHand
    With cn
        .ConnectionString = "Driver={SQL Server};Server=" & servername & _
            ";Database=" & dbname & ";" & _
            "Uid=" & uname & ";" & _
            "Pwd=" & pword
            .Open
    End With

' Teste 2 - Usando conexão OLEDB:
' On Error GoTo ErrHand
'   With cn
'        .ConnectionString = "Provider=SQLOLEDB;Data Source=" & servername & ";" & _
'            "Initial Catalog=" & dbname & ";" & _
'            "User ID=" & uname & ";" & _
'            "Password=" & pword & ";"
'            .Open
'    End With

    Call MsgBox("Conexão com o banco de dados OK!", vbOKOnly + vbInformation, "Sucesso")

'******************************************************
' Faz a consulta SQL
'******************************************************
Dim rs As ADODB.Recordset
Dim sqlString As String
Set rs = New ADODB.Recordset

sqlString = "SELECT * from " & tablename
rs.Open sqlString, cn, adOpenStatic, adLockOptimistic
cn.Execute (sqlString)

'******************************************************
' Coloca dados na planilha
'******************************************************
Dim fld as ADODB.Field
Dim iSheet as Integer

iSheet = Sheets(sheetname).Index

' Cria o cabeçalho
i = 0 
With Worksheets(iSheet).Range("A1") 
  For Each fld In rs.Fields 
   .Offset(0, i).Value = fld.Name 
   i = i + 1 
 Next fld 
End With 

' Transfere os dados
Worksheets(iSheet).Range("A2").CopyFromRecordset rs

ExitHere:
 On Error Resume Next
 cn.Close
 Set cn = Nothing
 Err.Clear
 Exit Sub

ErrHand:
 MsgBox "Conexão não definida.", vbExclamation
 Resume ExitHere

End Sub

I adapted that function from this source, unfortunately I couldn’t test.