Exportar de Excel a Access mediante formulario de vba

adrian83 says:

Hola Sergio,

Muchas gracias por el ejemplo pero tengo una duda, tome el ejemplo y lo modifique para poder agregar a una base de datos de clientes para tomar esos dartos y hacer facturas.

Hice una base de datos de access llamada facturas y una tabla llamada clientes,y no uso la ventana principal de seleccionar asesor solo la de captura. Tengo el siguiente problema : al correr la ventana de captura se ejecuta correctamente al terminar de capturar y dar click en el boton de alta me aparece un msgbox con la palabra erro y no me pasa la informacion ala base de datos. Si me pudieras ayudar de favor seria excelente.

Adjunto codigo de formulario capturar:
Rem Codigo tomado de:
Rem http://www.erlandsendata.no/english/index.php?d=envbadacexportado
Rem Usado y modificado por Sergio A Campos H
‘
‘Option Explicit
Private Declare Function FindWindow Lib “user32” Alias “FindWindowA” (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function DrawMenuBar Lib “user32” (ByVal hWnd As Long) As Long
Private Declare Function SetWindowLong Lib “user32” Alias “SetWindowLongA” (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib “user32” Alias “GetWindowLongA” (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Const WS_MINIMIZEBOX As Long = &H20000
Private Const WS_MAXIMIZEBOX As Long = &H10000
Private Const GWL_STYLE As Long = (-16)

Private Sub UserForm_Initialize()
Dim lngMyHandle As Long, lngCurrentStyle As Long, lngNewStyle As Long
If Application.Version < 9 Then
lngMyHandle = FindWindow("THUNDERXFRAME", Me.Caption)
Else
lngMyHandle = FindWindow("THUNDERDFRAME", Me.Caption)
End If
lngCurrentStyle = GetWindowLong(lngMyHandle, GWL_STYLE)
lngNewStyle = lngCurrentStyle Or WS_MINIMIZEBOX ' Or WS_MAXIMIZEBOX
SetWindowLong lngMyHandle, GWL_STYLE, lngNewStyle
End Sub
'
Private Sub CommandButton1_Click()
Unload Me
Application.Visible = True
End Sub

Private Sub CommandButton2_Click()
On Error GoTo fin
Dim cn As ADODB.Connection, rs As ADODB.Recordset, n As Long
Dim nfila As String
'
If txtRfc = "" Or txtrsocial = "" Or txtDomicilio = "" Or txtColonia = "" Or txtCiudad = "" Or txtEstado = "" Or txtCp = "" Then
MsgBox "No se puede continuar. Algunos datos obligatorios no pueden estar en blanco."
txtRfc.SetFocus
Exit Sub
End If
'
Set cn = New ADODB.Connection
cn.Open "provider=microsoft.jet.oledb.4.0; " & "data source=" & ThisWorkbook.Path & "facturacion.mdb;"
Set rs = New ADODB.Recordset
rs.Open "Clientes", cn, adOpenKeyset, adLockOptimistic, adCmdTable
'
With rs
.AddNew
.Fields("RFC") = Me.txtRfc.Value
.Fields("Razon Social") = Me.txtrsocial.Value
.Fields("Domicilio") = Me.txtDomicilio.Value
.Fields("Colonia") = Me.txtColonia.Value
.Fields("Estado") = Me.txtEstado.Value
.Fields("Ciudad") = Me.txtCiudad.Value
.Fields("Codigo Postal") = Me.txtCp.Value
End With
'
With rs
.AddNew
.Fields("RFC") = Me.txtRfc.Value
.Fields("Razon Social") = Me.txtrsocial.Value
.Fields("Domicilio") = Me.txtDomicilio.Value
.Fields("Colonia") = Me.txtColonia.Value
.Fields("Estado") = Me.txtEstado.Value
.Fields("Ciudad") = Me.txtCiudad.Value
.Fields("Codigo Postal") = Me.txtCp.Value
End With
'
Set rs = Nothing
cn.Close
Set cn = Nothing
'
MsgBox prompt:="Los datos fueron enviados correctamente", Buttons:=vbOKOnly, Title:="DATOS GUARDADOS"
'
txtRfc = ""
txtrsocial = ""
txtDomicilio = ""
txtColonia = ""
txtEstado = ""
txtCiudad = ""
txtCp = ""

'
Me.txtRfc.SetFocus
Exit Sub
fin:
Application.Visible = True
MsgBox "Error"
End Sub
'
Private Sub txtRfc_Change()
Text = UCase(txtRfc)
txtRfc = Text
End Sub

Private Sub txtrsocial_Change()
Text = UCase(txtrsocial)
txtrsocial = Text
End Sub

Private Sub txtDomicilio_Change()
Text = UCase(txtDomicilio)
txtDomicilio = Text
End Sub

Private Sub txtColonia_Change()
Text = UCase(txtColonia)
txtColonia = Text
End Sub

Private Sub txtEstado_Change()
Text = UCase(txtEstado)
txtEstado = Text
End Sub

Private Sub txtCiudad_Change()
Text = UCase(txtCiudad)
txtCiudad = Text
End Sub

Private Sub txtCp_Change()
Text = UCase(txtCp)
txtCp = Text
End Sub

Muchas Gracias Saludos!

David Garcia says:

Buenas noches

Señor Sergio

Queria preguntarle; que le parece este código que modifiqué:

Sub ADOFromExcelToAccess()
‘Menu herramientas/ Referencias
‘Marca el Microsoft Activex Data Object 2.6 Library
Dim cn As ADODB.Connection, rs As ADODB.Recordset, r As Integer
Set cn = New ADODB.Connection
cn.Open “Provider=Microsoft.ACE.OLEDB.12.0; ” & _
“Data Source= ” & ThisWorkbook.Path & “Access.accdb;” ‘ ruta del Archivo Acces en formato 2007
Set rs = New ADODB.Recordset
rs.Open “consulta”, cn, adOpenKeyset, adLockOptimistic, adCmdTable ‘ nombre de la tabla entre comillas

For r = 0 To UserForm1.ListBox1.ListCount – 1
With rs
.AddNew
.Fields(“Numero”) = UserForm1.ListBox1.List(0, r)
.Fields(“Nombre”) = UserForm1.ListBox1.List(1, r)
.Fields(“Apellido Paterno”) = UserForm1.ListBox1.List(2, r)
.Fields(“Apellido Materno”) = UserForm1.ListBox1.List(3, r)
.Update
End With

Next
rs.Close
Set rs = Nothing
cn.Close
Set cn = Nothing
End Sub

Espero poder contar con su evaluación.

Mis respetos.

Victor Melendez says:

Hola Sergio, buena tarde, intento bajar el archivo de ejemplo que tienes y me marca que no existe la pagina, publicaste otra que a dropbox e indica que no tiene el archivo, si no es molestia me lo puedes enviar a mi correo personal o puedes volver a subir el link por fa???

Gracias de antemano.