Buenas noches estimados,

Recurro nuevamente a ustedes para solicitar amablemente su ayuda, diseñé un formulario en Excel de consulta, que importa la información de una base de datos en Access, el cual tiene filtros que funcionan individuales o combinados, el problema es que el código que realiza la búsqueda se tiene que repetir en total 25 veces, todo exactamente igual, lo único que varía son las condicionales para la búsqueda, creen que se pueda reducir las líneas o hacerlo de otro modo que no requiera un código tan extenso?, esta es la imagen del formulario:

Como pueden observar es sencillo, solamente los filtros de búsqueda son los que hacen que se repita el código, ya que se puede filtrar con un solo textbox o con combinaciones (Ejemplo Arete, Desde y N° de Corral). Este es el código que utilizo:

Private Sub VerAreteDesdeNCorral()
Dim Conn As ADODB.Connection
Dim MiConexion
Dim Rs As ADODB.Recordset
Dim Campo As String
Dim Query As String
Dim i, j

Campo = "BDEntradas.accdb"

Set Conn = New ADODB.Connection
MiConexion = Application.ThisWorkbook.Path & Application.PathSeparator & Campo

With Conn
    .Provider = "Microsoft.ACE.OLEDB.12.0"
    .Open MiConexion
End With

'EN ESTE CASO LA BÚSQUEDA LA REALIZA EN BASE A LOS FILTROS DE ARETE, DESDE Y N° DE CORRAL
Query = "SELECT * FROM Ordeño WHERE [ARETE] = '" & Me.txt_Arete.Text & "' and [FECHA] >= #" & Format(Me.txt_Desde.Value, "mm/dd/yyyy") & "# and [NCORRAL] = '" & Me.txt_NCorral.Text & "' and [MASTITIS] = ""NO"" and [ESTADO] = ""ACTIVO"" "

Set Rs = New ADODB.Recordset
Rs.CursorLocation = adUseServer
Rs.Open Source:=Query, _
ActiveConnection:=Conn

If Rs.EOF And Rs.BOF Then
    Rs.Close
    Conn.Close
    Set Rs = Nothing
    Set Conn = Nothing
    MsgBox "No hay registros para el filtro consultado", vbInformation
    Me.ListBox1.Clear
    Exit Sub
End If

Rs.MoveFirst
i = 1

With Me.ListBox1
    .Clear
    
    .AddItem
    
        .List(j, 0) = "Id"
        .List(j, 1) = "Fecha"
        .List(j, 2) = "Turno"
        .List(j, 3) = "Arete"
        .List(j, 4) = "Nombre"
        .List(j, 5) = "N° Corral"
        .List(j, 6) = "Tipo Corral"
        .List(j, 7) = "Litros"
    
    Do
        .AddItem
        .List(i, 0) = Rs![ID]
        .List(i, 1) = Rs![Fecha]
        .List(i, 2) = Rs![TURNO]
        .List(i, 3) = Rs![Arete]
        .List(i, 4) = Rs![Nombre]
        .List(i, 5) = Rs![NCorral]
        .List(i, 6) = Rs![TCORRAL]
        .List(i, 7) = FormatNumber(Rs![Litros], 2)
        i = i + 1
        Rs.MoveNext
        
    Loop Until Rs.EOF
End With

Rs.Close
Conn.Close
Set Rs = Nothing
Set Conn = Nothing
End Sub

Ese código lo repito 25 veces para las 25 combinaciones posibles que se pueden realizar al usar los filtros. Desde ya quedo muy agradecido con su tiempo y sus comentarios. Saludos cordiales.

Posdata: No pude subir el archivo, eliminé todos los formularios, dejando solamente el que quiero mostrarles, eliminé todas las hojas y borré el contenido de la única hoja que quedaba y aún así el archivo pesó 102.4 Kb, lo cual no me permitió subir el archivo para compartirlo, por eso es que solamente le tomé captura al formulario y copié el código que uso, espero su comprensión

Buenas, sin el archivo para probarlo te diría que puedes utilizar parámetros en la sub entre otras cosas.

 

saludos

 

Con un único procedimiento, sería algo así:

Dim WHERE As String, Arete As String, Desde As String, Hasta As String, NCorral As String

If Not txt_Arete = "" Then Arete = " and [ARETE] = '" & txt_Arete & "'"
If Not txt_Desde = "" Then Desde = " and [FECHA] >= #" & Format(txt_Desde, "mm/dd/yyyy") & "#"
If Not txt_Hasta = "" Then Hasta = " and [FECHA] <= #" & Format(txt_Desde, "mm/dd/yyyy") & "#"
If Not txt_NCorral = "" Then NCorral = " and [NCORRAL] = '" & txt_NCorral & "'"

WHERE = Arete & Desde & Hasta & NCorral & " and [MASTITIS] = ""NO"" and [ESTADO] = ""ACTIVO"""
WHERE = Mid(WHERE, 6)

Query = "SELECT * FROM Ordeño WHERE " & WHERE