EXCELeINFO

Conectar Excel a Access, MySql y SQL

by · 8 February, 2011

Twittear este post Compartir en Facebook

En esta ocasión comparto 3 archivos que actualmente utilizo para dar de alta datos a bases de datos de Access, SQL y MySql desde Excel. Lo importante es saber exactamente el nombre de la base de datos, la tabla, y en el caso de SQL y MySql, el servidor, usuario y contraseña.

Comparto las macros que nos permiten hacer la tarea antes mencionada, aunque los archivos adjuntos son completamente funcionales.

Excel a Access

Sub exportaraccess()
    Dim cn As ADODB.Connection, rs As ADODB.Recordset, n As Long
    Dim nfila As String
    '
    On Error GoTo Errores
    If Range("a2") = "" Or Range("b2") = "" Or Range("c2") = "" Or Range("d2") = "" Or Range("e2") = "" Then
        MsgBox prompt:="No hay datos para exportar", Buttons:=vbOKOnly + vbCritical, Title:="Campos vacios"
        Exit Sub
    End If
    '
    Set cn = New ADODB.Connection
    cn.Open "provider=microsoft.jet.oledb.4.0; " & "data source=" & ThisWorkbook.Path & "" & shtListas.Range("rngBase") & ".MDB;"
    'cn.Open "provider=microsoft.jet.oledb.4.0; " & "data source=" & ThisWorkbook.Path & "GUION.MDB;"
    Set rs = New ADODB.Recordset
    rs.Open shtListas.Range("rngTabla"), cn, adOpenKeyset, adLockOptimistic, adCmdTable
    n = 2
    Do While Range("a" & n) <> Empty
        With rs
            .AddNew
            .Fields("Nombre") = Range("a" & n).Value
            .Fields("Cuenta") = Range("b" & n).Value
            .Fields("Password") = Range("c" & n).Value
            .Fields("Permisos") = Range("d" & n).Value
            .Fields("Campana") = Range("e" & n).Value
            .Fields("Supervisor") = Range("f" & n).Value
            .Fields("Monitoreos") = Range("g" & n).Value
            .Fields("Estatus") = Range("h" & n).Value
            .Fields("Nivel") = Range("i" & n).Value
            .Fields("Tipo") = Range("j" & n).Value
            .Fields("Grupo") = Range("k" & n).Value
            .Fields("No Empleado") = Range("l" & n).Value
            .Fields("Fecha Ingreso") = Date
        End With
        n = n + 1
    Loop
    With rs
        .AddNew
        .Fields("Nombre") = Range("a" & n).Value
        .Fields("Cuenta") = Range("b" & n).Value
        .Fields("Password") = Range("c" & n).Value
        .Fields("Permisos") = Range("d" & n).Value
        .Fields("Campana") = Range("e" & n).Value
        .Fields("Supervisor") = Range("f" & n).Value
        .Fields("Monitoreos") = Range("g" & n).Value
        .Fields("Estatus") = Range("h" & n).Value
        .Fields("Nivel") = Range("i" & n).Value
        .Fields("Tipo") = Range("j" & n).Value
        .Fields("Grupo") = Range("k" & n).Value
        .Fields("No Empleado") = Range("l" & n).Value
        .Fields("Fecha Ingreso") = Date
    End With
    '
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    '
    MsgBox prompt:="Los datos fueron enviados correctamente", Buttons:=vbOKOnly, Title:="DATOS EXPORTADOS"
    Range("a2").Activate
    '
    If [a3] = Empty Then
        Range("a2", Selection.End(xlToRight)).ClearContents
        Exit Sub
    End If
    nfila = Range("A65535").End(xlUp).Row
    '    Range("a2:F" + nfila).ClearContents
    Exit Sub
Errores:
    MsgBox Err.Description & vbNewLine & vbNewLine & "Recuerda que el archivo debe estar en la misma ruta de la base de datos.", vbCritical, empresa
End Sub
Sub exportaraccess()
    Dim cn As ADODB.Connection, rs As ADODB.Recordset, n As Long
    Dim nfila As String
    '
    On Error GoTo Errores
    If Range("a2") = "" Or Range("b2") = "" Or Range("c2") = "" Or Range("d2") = "" Or Range("e2") = "" Then
        MsgBox prompt:="No hay datos para exportar", Buttons:=vbOKOnly + vbCritical, Title:="Campos vacios"
        Exit Sub
    End If
    '
    Set cn = New ADODB.Connection
    cn.Open "provider=microsoft.jet.oledb.4.0; " & "data source=" & ThisWorkbook.Path & "" & shtListas.Range("rngBase") & ".MDB;"
    'cn.Open "provider=microsoft.jet.oledb.4.0; " & "data source=" & ThisWorkbook.Path & "GUION.MDB;"
    Set rs = New ADODB.Recordset
    rs.Open shtListas.Range("rngTabla"), cn, adOpenKeyset, adLockOptimistic, adCmdTable
    n = 2
    Do While Range("a" & n) <> Empty
        With rs
            .AddNew
            .Fields("Nombre") = Range("a" & n).Value
            .Fields("Cuenta") = Range("b" & n).Value
            .Fields("Password") = Range("c" & n).Value
            .Fields("Permisos") = Range("d" & n).Value
            .Fields("Campana") = Range("e" & n).Value
            .Fields("Supervisor") = Range("f" & n).Value
            .Fields("Monitoreos") = Range("g" & n).Value
            .Fields("Estatus") = Range("h" & n).Value
            .Fields("Nivel") = Range("i" & n).Value
            .Fields("Tipo") = Range("j" & n).Value
            .Fields("Grupo") = Range("k" & n).Value
            .Fields("No Empleado") = Range("l" & n).Value
            .Fields("Fecha Ingreso") = Date
        End With
        n = n + 1
    Loop
    With rs
        .AddNew
        .Fields("Nombre") = Range("a" & n).Value
        .Fields("Cuenta") = Range("b" & n).Value
        .Fields("Password") = Range("c" & n).Value
        .Fields("Permisos") = Range("d" & n).Value
        .Fields("Campana") = Range("e" & n).Value
        .Fields("Supervisor") = Range("f" & n).Value
        .Fields("Monitoreos") = Range("g" & n).Value
        .Fields("Estatus") = Range("h" & n).Value
        .Fields("Nivel") = Range("i" & n).Value
        .Fields("Tipo") = Range("j" & n).Value
        .Fields("Grupo") = Range("k" & n).Value
        .Fields("No Empleado") = Range("l" & n).Value
        .Fields("Fecha Ingreso") = Date
    End With
    '
    Set rs = Nothing
    cn.Close
    Set cn = Nothing
    '
    MsgBox prompt:="Los datos fueron enviados correctamente", Buttons:=vbOKOnly, Title:="DATOS EXPORTADOS"
    Range("a2").Activate
    '
    If [a3] = Empty Then
        Range("a2", Selection.End(xlToRight)).ClearContents
        Exit Sub
    End If
    nfila = Range("A65535").End(xlUp).Row
    '    Range("a2:F" + nfila).ClearContents
    Exit Sub
Errores:
    MsgBox Err.Description & vbNewLine & vbNewLine & "Recuerda que el archivo debe estar en la misma ruta de la base de datos.", vbCritical, empresa
End Sub

Excel a MySql (será necesario descargar el driver 5.1 de MySql)

Dim oConn As ADODB.Connection
Dim rs As ADODB.Recordset
'
Function ExcelMySql()
    On Error GoTo err
    Set oConn = New ADODB.Connection
    oConn.Open "DRIVER={MySQL ODBC 5.1 Driver};" & _
               "SERVER=100.1.11.11;" & _
               "DATABASE=bd_database;" & _
               "USER=user;" & _
               "PASSWORD=pass;" & _
               "Option=3"
    Exit Function
err:
    MsgBox "Se ha producido el siguiente error: " & err.Description, vbInformation, ActiveWorkbook.Name
End Function
'
Function esc(txt As String)
    esc = Trim(Replace(txt, "'", "'"))
End Function
'
'
Function InsertData()
    On Error GoTo Er
    'Se elimina la llamada a la función de conexión a la base de datos para hacerlo cuando inicie el archivo
    ' Call ConnectDB
    Set rs = New ADODB.Recordset
    sFunction = Application.WorksheetFunction.CountA(Range("A:A"))
    '
    With shInsertData
        For rowCursor = 2 To sFunction
            strSQL = "INSERT INTO tbl_cat_usuarios (ID_txtusuariotelsys, txt_clavetelsys, txt_nombre, txt_apepat, txt_apemat, bin_statusactivo, bin_nivel) " & _
                     "VALUES ('" & esc(.Cells(rowCursor, 1)) & "', " & _
                     "'" & esc(.Cells(rowCursor, 2)) & "', " & _
                     "'" & esc(.Cells(rowCursor, 3)) & "', " & _
                     "'" & esc(.Cells(rowCursor, 4)) & "', " & _
                     "'" & esc(.Cells(rowCursor, 5)) & "', " & _
                     esc(.Cells(rowCursor, 6)) & ", " & _
                     esc(.Cells(rowCursor, 7)) & ")"
            '
            'strSQL = "INSERT INTO tutorial (title, author, price) " & _
             "VALUES ('" & esc(.Cells(rowCursor, 1)) & "', " & _
             "'" & esc(.Cells(rowCursor, 2)) & "', " & _
             esc (.Cells(rowCursor, 3)) & ")"
            rs.Open strSQL, oConn, adOpenDynamic, adLockOptimistic
        Next
    End With
    MsgBox "Exito", vbInformation
    Exit Function
Er:
    MsgBox "Error: " & err.Description, vbInformation, ActiveWorkbook.Name
End Function

Excel a SQL

Dim oConn As ADODB.Connection
Dim rs As ADODB.Recordset
'
Function ConnectDB()
    On Error GoTo err
    Set oConn = New ADODB.Connection
    oConn.Open "Provider=SQLOLEDB.1;" & _
               "Password=pass;" & _
               "Persist Security Info=True;" & _
               "User ID=user;" & _
               "Initial Catalog=BASE;" & _
               "Data Source=100.1.111.11"
    MsgBox "Éxito al conectarse a la base de datos", vbInformation, "1"
    Exit Function
err:
    MsgBox "Se ha producido el siguiente error: " & err.Description, vbInformation, ActiveWorkbook.Name
End Function
'
Function esc(txt As String)
    esc = Trim(Replace(txt, "'", "'"))
End Function
'
'
Function InsertData()
    On Error GoTo Er
    'Se elimina la llamada a la función de conexión a la base de datos para hacerlo cuando inicie el archivo
    ' Call ConnectDB
    Set rs = New ADODB.Recordset
    sFunction = Application.WorksheetFunction.CountA(Range("A:A"))
    '
    With shInsertData
        For rowCursor = 2 To sFunction
            strSQL = "INSERT INTO tbl_operador (ID, txt_nombre, txt_apepat, txt_apemat, txt_tipocuenta, bit_activo, txt_rol, pws_contra) " & _
                     "VALUES ('" & esc(.Cells(rowCursor, 1)) & "', " & _
                     "'" & esc(.Cells(rowCursor, 2)) & "', " & _
                     "'" & esc(.Cells(rowCursor, 3)) & "', " & _
                     "'" & esc(.Cells(rowCursor, 4)) & "', " & _
                     "'" & esc(.Cells(rowCursor, 5)) & "', " & _
                     "'" & esc(.Cells(rowCursor, 6)) & "', " & _
                     esc(.Cells(rowCursor, 7)) & ", " & _
                     "'" & esc(.Cells(rowCursor, 8)) & "' )"
            '
            rs.Open strSQL, oConn, adOpenDynamic, adLockOptimistic
        Next
    End With
    MsgBox "Las claves fueron dadas de alta correctamente.", vbInformation, "EXCELeINFO"
    Exit Function
Er:
    MsgBox "Error: " & err.Description, vbCritical, "EXCELeINFO"
End Function

:: Descargar zip con ejemplos

Tags:

You may also like...