Jump to content
giordancisco

llenar listbox de excel con datos de acces

Recommended Posts

Necesito realizar una consulta desde un userform en excel a una base de datos Acces y que dicha consulta se almacene en un listbox del userform de excel, el problema es que mediante bucles y loops con additems se tarda demasiado en llenar, y necesito saber si es posible que se realice mediante un rowsource como si fuera en un listbox alojado en acces. Si pudiera conseguir esa velocidad de filtrado de información estaría mas que agradecido-

Actualmente utilizo este código poco elegante que copia los datos filtrados de la base de datos acces a la hoja de calculo de de excel y desde ahí se captura el rango de datos para almacenarlo en el listbox. Si bien al realizar el doble trabaje se tarda un poco mas, sigue siendo mas rápido que utilizar loop y additems.

Private Sub CommandButton1_Click()
Dim Base As String
Dim Sql As String
Dim rscopy As String

Dim Conexion As String
Conexion = "PROVIDER=MICROSOFT.ACE.OLEDB.12.0;DATA SOURCE =" & "E:\Dropbox\MIS PROGRAMAS\ACCES\Buscador de Precios 64 bits 9-4-19.accdb" & ";PERSIST SECURITY INFO FALSE;"
uf2 = Sheets("ACCES").Range("I" & Rows.Count).End(xlUp).Row

Sheets("ACCES").Range("B11:I" & uf2).Clear

'LLAMAMOS AL OBJETO ADO
Set cn = New ADODB.Connection
'ABRIMOS LA CONEXION
cn.Open Conexion
'CREAMOS LA CONSULTA
Set rs = New ADODB.Recordset

With rs
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
End With

'Consulta = Consulta & " WHERE " & Me.cmbCampo & " Like '*" & Me.txtBusqueda.Text & "*'"
'Sql = "SELECT * FROM Personas where Descripción like " & "'%" & Range("D6") & "%'"
'Like Replace("'%" & UCase(txtBusqueda.Value) & "%'", " ", "%") And
'Sql = "SELECT * FROM Personas where Descripción like " & "'%" & txtBusqueda & "%'"
Sql = "SELECT * FROM Personas where Descripción like " & Replace("'%" & UCase(txtBusqueda.Value) & "%'", " ", "%")
rs.Open Sql, Conexion

Range("B11").CopyFromRecordset rs

uf = Sheets("ACCES").Range("I" & Rows.Count).End(xlUp).Row
Me.Lista.RowSource = "ACCES!B11:I" & uf
cn.Close

Set rs = Nothing
Set cn = Nothing


End Sub

 

Desde ya muchas gracias y saludos.

Share this post


Link to post
Share on other sites

Hola

Te copio y pego lo respondido en otro foro:

Los Listbox de Excel son distintos a los de Access, a pesar de sus varias similitudes. En el caso de Excel, su propiedad "RowSource" solo acepta rangos de celdas y no es posible adaptarle algo como un Recordset.

Las opciones son usar List o AddItem, pero en ambos casos hay que recorrer y agregar registro por registro. La otra opción es la que ya usas tú de pegar todo en una hoja y luego pasarlo al ListBox con "RowSource".

Particularmente yo prefiero hacerlo desde el Recorsset directamente:

Do While Not rst.EOF
     ListBox1. AddItem rst. Fields(0)
     Rst. MoveNext
Loop

Saludos

Abraham Valencia

PD: Los usuarios de los foros de Excel somos muchas veces recurrentes en varios foros de habla hispana, basta con dejar la pregunta en uno

Share this post


Link to post
Share on other sites

Hola @giordancisco , tal como lo indica avalencia no puedes utilizar un RowSource en un listbox utilizando como fuente un recorset, pero puedes utilizar la siguiente instrucción:

sql = "Tu consulta"

rs.Open Sql, Conexion

ListBox1.Column = Rs.GetRows

Con esto no hay nesecidad de utilizar un bucle para llenar el listbox

Saludos.

Share this post


Link to post
Share on other sites
Hace 1 hora, AlexanderS dijo:

Hola @giordancisco , tal como lo indica avalencia no puedes utilizar un RowSource en un listbox utilizando como fuente un recorset, pero puedes utilizar la siguiente instrucción:


sql = "Tu consulta"

rs.Open Sql, Conexion

ListBox1.Column = Rs.GetRows

Con esto no hay nesecidad de utilizar un bucle para llenar el listbox

Saludos.

Muchas gracias señor Alexander, Lo probe y funciono! estoy muy feliz, le quiero mucho señor. 

Share this post


Link to post
Share on other sites

Tengo un nuevo problema. Cuando no encuentra registros me salta el error 3021 "el valor de bof o eof es true o el actual registro se elimino".

este es el código que estoy manejando

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Base As String
Dim Sql As String
Dim rscopy As String

'E:\Dropbox\MIS PROGRAMAS\ACCES\Buscador de Precios 64 bits 9-4-19.accdb

Dim Conexion As String
Conexion = "PROVIDER=MICROSOFT.ACE.OLEDB.12.0;DATA SOURCE =" & txtruta.Value & ";PERSIST SECURITY INFO FALSE;"
'uf2 = Sheets("ACCES").Range("I" & Rows.Count).End(xlUp).Row

'Sheets("ACCES").Range("B11:I" & uf2).Clear

'LLAMAMOS AL OBJETO ADO
Set cn = New ADODB.Connection
'ABRIMOS LA CONEXION
cn.Open Conexion
'CREAMOS LA CONSULTA
Set rs = New ADODB.Recordset

With rs
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
End With

'Consulta = Consulta & " WHERE " & Me.cmbCampo & " Like '*" & Me.txtBusqueda.Text & "*'"
'Sql = "SELECT * FROM Personas where Descripción like " & "'%" & Range("D6") & "%'"
'Like Replace("'%" & UCase(txtBusqueda.Value) & "%'", " ", "%") And
'Sql = "SELECT * FROM Personas where Descripción like " & "'%" & txtBusqueda & "%'"

''cmbCampo.value'
If cmbCampo.Value <> "" Then
Sql = "SELECT * FROM Personas where Descripción like " & Replace("'%" & UCase(txtBusqueda.Value) & "%'", " ", "%") & "AND Proveedor = " & "'" & cmbCampo.Value & "'"
Else
Sql = "SELECT * FROM Personas where Descripción like " & Replace("'%" & UCase(txtBusqueda.Value) & "%'", " ", "%")

End If

rs.Open Sql, Conexion
Lista.Column = rs.GetRows

'Range("B11").CopyFromRecordset rs

'uf = Sheets("ACCES").Range("I" & Rows.Count).End(xlUp).Row
'Me.Lista.RowSource = "ACCES!B11:I" & uf

cn.Close
rs.Close
Set rs = Nothing
Set cn = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

Desde ya muchas gracias. saludos

Share this post


Link to post
Share on other sites
Hace 22 minutos , giordancisco dijo:

Tengo un nuevo problema. Cuando no encuentra registros me salta el error 3021 "el valor de bof o eof es true o el actual registro se elimino".

este es el código que estoy manejando

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Base As String
Dim Sql As String
Dim rscopy As String

'E:\Dropbox\MIS PROGRAMAS\ACCES\Buscador de Precios 64 bits 9-4-19.accdb

Dim Conexion As String
Conexion = "PROVIDER=MICROSOFT.ACE.OLEDB.12.0;DATA SOURCE =" & txtruta.Value & ";PERSIST SECURITY INFO FALSE;"
'uf2 = Sheets("ACCES").Range("I" & Rows.Count).End(xlUp).Row

'Sheets("ACCES").Range("B11:I" & uf2).Clear

'LLAMAMOS AL OBJETO ADO
Set cn = New ADODB.Connection
'ABRIMOS LA CONEXION
cn.Open Conexion
'CREAMOS LA CONSULTA
Set rs = New ADODB.Recordset

With rs
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockOptimistic
End With

'Consulta = Consulta & " WHERE " & Me.cmbCampo & " Like '*" & Me.txtBusqueda.Text & "*'"
'Sql = "SELECT * FROM Personas where Descripción like " & "'%" & Range("D6") & "%'"
'Like Replace("'%" & UCase(txtBusqueda.Value) & "%'", " ", "%") And
'Sql = "SELECT * FROM Personas where Descripción like " & "'%" & txtBusqueda & "%'"

''cmbCampo.value'
If cmbCampo.Value <> "" Then
Sql = "SELECT * FROM Personas where Descripción like " & Replace("'%" & UCase(txtBusqueda.Value) & "%'", " ", "%") & "AND Proveedor = " & "'" & cmbCampo.Value & "'"
Else
Sql = "SELECT * FROM Personas where Descripción like " & Replace("'%" & UCase(txtBusqueda.Value) & "%'", " ", "%")

End If

rs.Open Sql, Conexion
Lista.Column = rs.GetRows

'Range("B11").CopyFromRecordset rs

'uf = Sheets("ACCES").Range("I" & Rows.Count).End(xlUp).Row
'Me.Lista.RowSource = "ACCES!B11:I" & uf

cn.Close
rs.Close
Set rs = Nothing
Set cn = Nothing

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

 

Desde ya muchas gracias. saludos

Lo solucione con la siguiente línea

rs.Open Sql, Conexion

If rs.EOF Then

MsgBox "No se encontraron registros."
Exit Sub
End If

Lista.Column = rs.GetRows

 

Disculpen las molestias 

Share this post


Link to post
Share on other sites
Guest
This topic is now closed to further replies.

×
×
  • Create New...

Important Information

Privacy Policy

Ayuda Excel - Madrid, Madrid, ES - Valorada por 5112 personas - Aprender Excel - Total: 4.7 / 5