Saltar al contenido

Filtrar datos entre dos fechas


Recommended Posts

publicado

Buenos días, estoy intentanto hacer un filtro avanzado en vba y no consigo que funcione. Estuve viendo un ejemplo que solucionaba Antoni pero ni así...

Os paso el código para ver si podeis darme un poco de ayuda.

Lo que me gustaría conseguir es un autofiltro  avanzado donde pueda filtra las filas entre dos fechas que yo introduzca con un "inputbox"


 Sub filtrarfecha()
    Dim FechaIni As date,

    Dim FechaFin As date
    
    FechaIni = InputBox("Ponga fecha inicio")
    FechaFin = InputBox("Ponga fecha fin")
   
    ActiveSheet.Range("a5:a13").AutoFilter field:=1, _
        Criteria1:=">=" & FechaIni, _
        Operator:=xlAnd, _
        Criteria2:="<=" & FechaFin
        
        ActiveSheet.AutoFilter.ApplyFilter
End Sub

 

Gracias por adelantado

publicado
Hace 16 horas, Antoni dijo:

Sube tu archivo con datos para poderprobar.

PruebaFiltro.xlsm Antoni es una tabla sencilla que he creado para familiarizarme con lo que quiero hacer,

Saludos  y muchas gracias Antoni

 

JSDJSD Gracias por tu  ejemplo, podrías si no es mucha molestia explicar el código?

publicado

Simplemente te reemplace esta  línea ListBoxLista.Clear  por ListBoxLista.RowSource = "", el resto del código es tuyo, de todos modos si necesitas una explicación del mismo te subo tu código comentariado.

** Cuando se usa RowSource para cargar ListBox no se puede borrar este con Clear, si no que tienes que usar la propiedad RowSource="" para borrarlo.

Private Sub BtnBuscar_Click()

    Dim fin As Long, i As Long, n As Long
    Dim sCadena_seccion As String
    
    Set FILTRAR = ActiveWorkbook.Worksheets("Listado")
       
    
    With FILTRAR
        fin = Application.CountA(.Range("A:A"))
        If TxtBuscador = "" Then
            Me.ListBoxLista.RowSource = ("A2:G") & FILTRAR.Range("A" & Rows.Count).End(xlUp).Row
            Exit Sub
        End If
        
        For i = 2 To fin
            sCadena_seccion = .Cells(i, 1).Value
            If UCase(sCadena_seccion) Like "*" & UCase(TxtBuscador.Value) & "*" Then
                ListBoxLista.RowSource = ""
                
                Me.ListBoxLista.AddItem
                Me.ListBoxLista.List(n, 0) = .Cells(i, 1).Value
                Me.ListBoxLista.List(n, 1) = .Cells(i, 2).Value
                Me.ListBoxLista.List(n, 2) = .Cells(i, 3).Value
                Me.ListBoxLista.List(n, 3) = .Cells(i, 4).Value
                Me.ListBoxLista.List(n, 4) = .Cells(i, 5).Value
                Me.ListBoxLista.List(n, 5) = .Cells(i, 6).Value
                Me.ListBoxLista.List(n, 6) = .Cells(i, 7).Value
                n = n + 1
            End If
        Next
        Me.ListBoxLista.ColumnWidths = "30pt;150pt;150pt;50pt;50pt;60pt;60pt"
    End With
End Sub

 

publicado
Hace 1 hora, JSDJSD dijo:

Perdón esto no tenía que ponerlo aquí.

ok JSDJSD, cuando puedas coméntame tu código porfa que me cuesta seguirlo.

El código que yo adjunté hace que se filtre todo y desaparecen los datos. No acabo de ver donde está el problema...Alguna idea?

Otra consulta, si el  formato de fecha que yo tengo en la tabla es "dd/mm/aaa hh:mm:ss" si meto en el inputbox la fecha formato "dd/mm/aaaa" filtrará correctamente?

 

Gracias por participar en el hilo.

publicado

Este si es el tuyo

Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)

    If KeyCode = 13 Then  ' Si pulsamos Enter  en textbox2 se ejecuta la macro
    
        date1 = TextBox1: Date2 = TextBox2 ' Asignamos  a las variales su valor
        
        With Sheets("Hoja1").Range("A1").CurrentRegion  ' Seleccionamos todo rango desde A1
        'Filtramos en la columna 1 según condicion por dos criterios en este caso >= y <=
        .AutoFilter 1, Criteria1:=">=" & CDbl(CDate(date1)), Operator:=xlAnd, Criteria2:="<=" & CDbl(CDate(Date2))
        Hoja3.Range("A1").CurrentRegion.Delete 'Borramos el contenido de la hoja3
        .SpecialCells(12).Copy Hoja3.Range("A1") 'Copiamos a partir del A1 las filas visibles del filtrado
        Me.ListBox1.RowSource = Hoja3.Range("A1"). _
        CurrentRegion.Offset(0).Address(, , , 1) ' Cargamos los datos en listbox
        .AutoFilter ' Quitamos filtro
        End With
    
    End If
    
End Sub

 

publicado

Tu macro con algún arreglillo ya funciona:

Sub filtrarfecha(): On Error GoTo ErrorFechas
    Dim FechaIni As Long
    Dim FechaFin As Long
    
    FechaIni = CLng(CDate(InputBox("Ponga fecha inicio")))
    FechaFin = CLng(CDate(InputBox("Ponga fecha fin")))
   
    ActiveSheet.Range("a5:a13").AutoFilter field:=1, _
        Criteria1:=">=" & FechaIni, _
        Operator:=xlAnd, _
        Criteria2:="<=" & FechaFin
        
   Exit Sub
ErrorFechas:
   MsgBox "Filtro cancelado por error en fechas introducidas", vbCritical
End Sub

 

publicado

He probado el código y funciona muy bien Antoni, quiero testearlo más para adaptarlo a más cosillas que quiero hacer.

JSDJSD me ha parecido muy interesante tu código, muchas gracias, me abre la mente para futuros códigos.

Muchas Gracias por la participación a  los dos, JSDJSD y Antoni. 

 

 

 

 

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

  • 109 ¿Te parecen útiles los tips de las funciones? (ver tema completo)

    1. 1. ¿Te parecen útiles los tips de las funciones?


      • No
      • Ni me he fijado en ellos

  • Ayúdanos a mejorar la comunidad

    • Donaciones recibidas este mes: 0.00 EUR
      Objetivo: 130.00 EUR
  • Archivos

  • Estadísticas de descargas

    • Archivos
      188
    • Comentarios
      98
    • Revisiones
      29

    Más información sobre "Cambios en el Control Horario"
    Última descarga
    Por pegones1

    4    1

  • Crear macros Excel

  • Mensajes

    • Buenos días  @LeandroA espero estes bien Tengo un caso idéntico al planteado en la siguiente pregunta: Sin embargo, a diferencia de quien planteo originalmente la pregunta al correr el código no obtengo ningún resultado podrían ayudarme a resolver este inconveniente y que al hacer click en el Botón Guardar (CommandButton3) del Formulario RCS (frmrcs) el archivo pdf quede configurado con orientación vertical, márgenes superior, inferior, derecho e izquierdo = 1 y en página tamaño carta. Si acaso influye uso Microsoft Excel LTSC MSO (versión 2209 Compilación16.0.1.15629.20200) de 64 bits Mucho le sabre agradecer la ayuda que me pueda dar  RCS PRUEBA - copia.xlsm
    • @JSDJSDCon gusto mi estimado Para la opción 1: Sub Surtirhastadondealcanse() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) Dim filaInicio As Integer: filaInicio = 4 Dim filaFin As Integer: filaFin = 7 Dim colInventario As Integer: colInventario = 2 Dim colSolicitudesInicio As Integer: colSolicitudesInicio = 4 ' Columna C Dim colResultadoInicio As Integer: colResultadoInicio = 9 ' Columna I Dim colTotalSurtido As Integer: colTotalSurtido = 12 ' Columna L Dim colFinalInventario As Integer: colFinalInventario = 13 ' Columna M Dim numClientes As Integer: numClientes = 3 Dim fila As Integer, i As Integer For fila = filaInicio To filaFin Dim inventario As Double inventario = Val(ws.Cells(fila, colInventario).Value) Dim solicitudes(1 To 3) As Double Dim surtido(1 To 3) As Variant Dim totalSurtido As Double: totalSurtido = 0 ' Leer solicitudes For i = 1 To numClientes If IsNumeric(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Then solicitudes(i) = CDbl(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Else solicitudes(i) = 0 End If surtido(i) = "POR FALTA STOCK" Next i ' Surtir de acuerdo al inventario disponible For i = 1 To numClientes If solicitudes(i) > 0 Then If inventario >= solicitudes(i) Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) ElseIf inventario > 0 Then surtido(i) = inventario totalSurtido = totalSurtido + inventario inventario = 0 Else surtido(i) = "POR FALTA STOCK" End If End If Next i ' Escribir resultados en las columnas correspondientes para cada cliente For i = 1 To numClientes With ws.Cells(fila, colResultadoInicio + i - 1) If surtido(i) = "POR FALTA STOCK" Then .Value = surtido(i) .Font.Color = vbRed Else .Value = surtido(i) .Font.Color = vbBlack End If End With Next i ' Escribir total surtido y existencia final ws.Cells(fila, colTotalSurtido).Value = totalSurtido ws.Cells(fila, colFinalInventario).Value = inventario Next fila MsgBox "Resultado surtido cargado con éxito...", vbInformation End Sub Para la opción 2:   Sub surtirenpartesiguales() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) Dim filaInicio As Integer: filaInicio = 13 Dim filaFin As Integer: filaFin = 16 Dim colInventario As Integer: colInventario = 2 Dim colSolicitudesInicio As Integer: colSolicitudesInicio = 4 ' Columna C Dim colResultadoInicio As Integer: colResultadoInicio = 9 ' Columna I Dim colTotalSurtido As Integer: colTotalSurtido = 12 ' Columna L Dim colFinalInventario As Integer: colFinalInventario = 13 ' Columna M Dim numClientes As Integer: numClientes = 3 Dim fila As Integer, i As Integer For fila = filaInicio To filaFin Dim inventario As Double inventario = Val(ws.Cells(fila, colInventario).Value) Dim solicitudes(1 To 3) As Double Dim surtido(1 To 3) As Variant Dim totalSurtido As Double: totalSurtido = 0 Dim totalPedido As Double: totalPedido = 0 ' Leer solicitudes For i = 1 To numClientes If IsNumeric(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Then solicitudes(i) = CDbl(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) totalPedido = totalPedido + solicitudes(i) Else solicitudes(i) = 0 End If surtido(i) = 0 Next i ' Si hay suficiente inventario, surtir lo que el cliente pide If inventario >= totalPedido Then For i = 1 To numClientes If solicitudes(i) > 0 And inventario >= solicitudes(i) Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) End If Next i Else ' Reparto base igualitario Dim baseSurtido As Long baseSurtido = Int(inventario / numClientes) For i = 1 To numClientes If solicitudes(i) > 0 Then If solicitudes(i) <= baseSurtido Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) Else surtido(i) = baseSurtido inventario = inventario - baseSurtido totalSurtido = totalSurtido + baseSurtido End If End If Next i ' Repartir sobrante restante uno por uno, respetando lo pedido Do While inventario > 0 For i = 1 To numClientes If surtido(i) < solicitudes(i) Then surtido(i) = surtido(i) + 1 totalSurtido = totalSurtido + 1 inventario = inventario - 1 If inventario = 0 Then Exit For End If Next i Loop End If ' Escribir resultados en las columnas correspondientes para cada cliente For i = 1 To numClientes With ws.Cells(fila, colResultadoInicio + i - 1) If surtido(i) = 0 Then .Value = "POR FALTA STOCK" .Font.Color = vbRed Else .Value = surtido(i) .Font.Color = vbBlack End If End With Next i ' Escribir total surtido y existencia final ws.Cells(fila, colTotalSurtido).Value = totalSurtido ws.Cells(fila, colFinalInventario).Value = inventario Next fila MsgBox "Resultado surtido cargado con éxito...", vbInformation End Sub Saludos, Diego
    • Buenos dias.  Estoy trabajando en una hoja para poder llevar un control de un pequeño almacén.  Tengo un pedido con varias líneas y "lotes" y necesito sacar las ubicaciones que coincidan con la referencia y lote que pone en el pedido. El problema viene cuando tengo la misma referencia y mismo lote en ubicaciones diferentes y necesito sacar la información en columnas diferentes. No se si  me he explicado bien, pero creo que con el ejemplo adjunto se entiende mejor. Agradecería mucho si me pudieran ayudar  Libro1.xlsx
    • Exelente solución mil gracias 
    • Podrías compartir tu solucion
  • Visualizado recientemente

    • No hay usuarios registrado para ver esta página.
×
×
  • Crear nuevo...

Información importante

Echa un vistazo a nuestra política de cookies para ayudarte a tener una mejor experiencia de navegación. Puedes ajustar aquí la configuración. Pulsa el botón Aceptar, si estás de acuerdo.