Macro para filtrar por mes

Me funciona pero es demasiado lento, se tarda hasta media hora en mostrar los resultados

¿Cuántos registros existen en cada hoja?

Puedes explicar con ejemplos lo que hace la macro, apóyate con algunas imágenes. Si los datos son confidenciales, utiliza datos genéricos. Procura que en las imágenes se vean las filas y las columnas.

hasta ahora lleva 3000 registros pero va aumentado

Para hacer una nueva macro, necesito que me expliques lo que quieres y ver una muestra de datos.

esta es la hoja donde estan los registros, el codigo lo que hace es que me busca entre fechas (inicial y final de la columna 2) y luego se extrae la cantidad (columna 5) de los items de la columna 1. todo lo que haya ingresado entre esas fechas es trasladado a otra hoja y lo separa por mes.

en la primer hoja los meses estan en la columna K

y en la segunda hoja estan en la fila 2

como mencione antes este codigo funciona pero me imagino que por ser demasiado datos en la hoja 1 se tarda tanto, y pensé si habia algun codigo que hiciera esto mas rapido

Dim colinfo As Integer
Dim filainfo As Integer
Dim filavtas As Integer
Dim filavtas1 As Integer
Dim filanom As Integer
Dim filanom1 As Integer
Dim Acum, Tacum As Currency
Dim dato1 As Date
Dim dato2 As Date
Dim condi1 As Date
Dim condi2 As Date
Dim dato3 As String
Dim dato4 As String
Dim dato5 As String
Dim dato6 As String
Sheets("Cuatri").Select
colinfo = 2
filainfo = 3
filavtas = 3
filanom = 3
filanom1 = 2
filavtas1 = 3

cond1 = TextBox1
cond2 = TextBox2
Acum = 0
Tacum = 0
'Realiza bucle mientras no haya columnas vacias
While Sheets("Cuatri").Cells(2, colinfo) <> Empty
'Realiza un nuevo bucle mietras no haya filas vacias recorriendo la fila de vtas
While Sheets("Cuatri").Cells(filainfo, 1) <> Empty
While Sheets("Entradas2").Cells(filanom, 1) <> Empty
dato1 = Sheets("Entradas2").Cells(filavtas, 2).Value 'fecha
dato2 = Sheets("Entradas2").Cells(filavtas, 2).Value 'fecha
dato3 = Sheets("Cuatri").Cells(2, colinfo).Value 'mes encabezado
dato4 = Sheets("Entradas2").Cells(filanom, 11).Value 'mes
dato5 = Sheets("Cuatri").Cells(filainfo, 1).Value 'items
dato6 = Sheets("Entradas2").Cells(filavtas, 1).Value 'items
If dato1 >= cond1 And dato2 <= cond2 And dato3 = dato4 And dato5 = dato6 Then
While Sheets("Entradas2").Cells(filavtas1, 1) <> Empty
dato4 = Sheets("Entradas2").Cells(filanom1, 11).Value 'mes
dato5 = Sheets("Cuatri").Cells(filainfo, 1).Value 'items
dato6 = Sheets("Entradas2").Cells(filavtas1, 1).Value 'items
If dato1 >= cond1 And dato2 <= cond2 And dato3 = dato4 And dato5 = dato6 Then
Acum = Sheets("Entradas2").Cells(filavtas1, 5) 'cantidad
Tacum = Tacum + Acum
Sheets("Cuatri").Cells(filainfo, colinfo) = Tacum 'cantidad
End If
filavtas1 = filavtas1 + 1
filanom1 = filanom1 + 1
Wend
End If
Acum = 0
Tacum = 0
filavtas1 = 2
filanom1 = 2
filanom = filanom + 1
filavtas = filavtas + 1
Wend
filavtas1 = 2
filanom1 = 2
filanom = 3
filavtas = 3
filainfo = filainfo + 1
Wend
filavtas1 = 2
filanom1 = 2
filanom = 3
filavtas = 3
filainfo = 3
colinfo = colinfo + 1
Wend

Sheets("Cuatri").Select
Range("B3:M1000").Select
Selection.NumberFormat = "0"
Range("A1").Select
'Sheets("listado OP").Protect Password:="miclave"
ActiveWindow.Zoom = 94
'Devuelvo movimientos a la pantalla
Application.ScreenUpdating = True

'For Each celda In Range(Range("a2"), Range("a65536").End(xlUp))
'If celda.Offset(0, 13).Value = 0 Then 'And celda.Offset(0, 3).Value = 0 And celda.Offset(0, 4) = 0 Then
'celda.EntireRow.Hidden = True
'End If
'Next
MsgBox "Proceso Completo"
End Sub

Como mencioné antes este código funciona pero me imagino que por ser demasiados datos en la hoja 1 se tarda tanto, y pensé si había algún código que hiciera esto más rápido

Esa parte ya la entendí.

Para hacer el nuevo código necesito que tú me expliques cuál es el objetivo final.

Con las imágenes que pusiste, explica qué quieres filtrar y en dónde quieres el resultado.

Ya no pongas código ni trates de explicar con macros, solamente con palabras simples explica lo que necesitas.

ok

el resultado debe ir en la hoja Cuatri, desglosado por mes

ejemplo

fecha inicial  01/01/2020

fecha final 25/04/2020

en ese rango de fechas hay tres mese y 25 dias de abril

entonces lo de enero debe desglosarse en la columa 2

lo de febrero en la columna 3

marzo en la 4

y asi sucesivamente 

dependiendo del rango de fechas

los datos estan en la hoja Entradas2 y el resultado en la hoja Cuatri

en la hoja entradas2 hay items repetidos y en un mismo mes puede haber entrado varias veces el mismo por lo cual debe sumarse el acumulado y colocarlo en el mes correspondiente.

En la hoja "Cuatri" existen todos los suministros, es decir, si un suministro existe en la hoja "Entradas2", entonces en la hoja "Cuatri" existe una vez, ¿correcto?

Supongo que la hoja "Cuatri" de las columnas B a M está limpia y la macro pone los resultados, ¿correcto?

exacto

en Entradas2 los items estan repetidos porque van ingresando por fechas (esto llevo haciendolo desde hace tres años aproximadamente, por eso hay mas de 3000 registros

y en Cuatri estan solo una vez(son como 238) , alli van los resultados

Hice una prueba con 4,000 registros y resultado es instantáneo.

No veo en dónde tienes las fechas para el filtro. Lo puse en la macro, puedes ajustar las fechas en esta línea:

If a(i, 2) >= CDate("01/01/2020") And a(i, 2) <= CDate("31/12/2020") Then

Según tus imágenes los datos en la hoja "Entradas2" empiezan en la celda A3. Y los datos en tu hoja "Cuatri" empiezan en A4.

Prueba el siguiente código.

Sub Filtrar_Mes()
'Por Dante Amor
'DECLARACIÓN de variables
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object, i As Long, j As Long, k As Long
'ENTRADAS
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  a = Sheets("Entradas2").Range("A3:E" & Sheets("Entradas2").Range("A" & Rows.Count).End(3).Row).Value2
  b = Sheets("Cuatri").Range("A4", Sheets("Cuatri").Range("A" & Rows.Count).End(3)).Value2
  ReDim c(1 To UBound(b), 1 To 12)
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = i
  Next
'PROCESO
  For i = 1 To UBound(a, 1)
    If a(i, 2) >= CDate("01/01/2020") And a(i, 2) <= CDate("31/12/2020") Then
      If dic.exists(a(i, 1)) Then
        j = dic(a(i, 1))
        k = Month(a(i, 2))
        c(j, k) = c(j, k) + a(i, 5)
      End If
    End If
  Next
'SALIDA
  Sheets("Cuatri").Range("B4").Resize(UBound(c, 1), 12).Value = c
End Sub

buen dia

gracias

pero necesito, como escribi arriba que tenga fecha inicial y fecha de corte

con este codigo solo me da todo 2020 y no puedo hacer corte por ejemplo

del 01/01/2020 al 31/01/2020

o del 01/05/2019 al 31/12/2019

en el codigo que tengo esta asi

If dato1 >= cond1 And dato2 <= cond2 And dato3 = dato4 And dato5 = dato6 Then

donde cond1 es la fecha inicial y cond2 es la fecha final

perdon 2019 no

solo 2020 pero por fecha inicial y corte

¿Probaste la macro?

¿Cuánto tiempo tardó?

Viste mi comentario:

No veo en dónde tienes las fechas para el filtro. Lo puse en la macro, puedes ajustar las fechas en esta línea:

If a(i, 2) >= CDate("01/01/2020") And a(i, 2) <= CDate("31/12/2020") Then

Solamente cambia las fechas en esa línea por el rango de fechas que tu quieras.

Pero no te preocupes si no sabes cómo ajustar la línea de código para la fecha inicial y la fecha final.

Veo en tu código que tienes un textbox1 para la fecha inicial y el textbox2 para la final.

En ambos textbox debes capturar la fecha con este formato: "dd/mm/aaaa", por ejemplo:

Si quieres del primero de mayo de año 2019 al 31 de diciembre del año 2019 entonces en los textbox debes capturar:

En el textbox1: 01/05/2019

En el textbox2: 31/12/2019

Entonces quedaría así:

Private Sub CommandButton2_Click()
'Por Dante Amor
'DECLARACIÓN de variables
  Dim a As Variant, b As Variant, c As Variant
  Dim dic As Object, i As Long, j As Long, k As Long
'ENTRADAS
  Set dic = CreateObject("Scripting.Dictionary")
  dic.CompareMode = vbTextCompare
  a = Sheets("Entradas2").Range("A3:E" & Sheets("Entradas2").Range("A" & Rows.Count).End(3).Row).Value2
  b = Sheets("Cuatri").Range("A4", Sheets("Cuatri").Range("A" & Rows.Count).End(3)).Value2
  ReDim c(1 To UBound(b), 1 To 12)
  For i = 1 To UBound(b, 1)
    dic(b(i, 1)) = i
  Next
'PROCESO
  For i = 1 To UBound(a, 1)
    If a(i, 2) >= CDate(TextBox1) And a(i, 2) <= CDate(TextBox2) And dic.exists(a(i, 1)) Then
      j = dic(a(i, 1))
      k = Month(a(i, 2))
      c(j, k) = c(j, k) + a(i, 5)
    End If
  Next
'SALIDA
  Sheets("Cuatri").Range("B4").Resize(UBound(c, 1), 12).Value = c
End Sub

Para 4,000 registros la siguiente macro es muy rápida, la respuesta en un segundo.

Private Sub CommandButton2_Click()
  Dim rng1 As Range, rng2 As Range, f As Range, c As Range
  Application.ScreenUpdating = False
  Set rng2 = Sheets("Cuatri").Range("A4", Sheets("Cuatri").Range("A" & Rows.Count).End(3))
  For Each c In Sheets("Entradas2").Range("A3", Sheets("Entradas2").Range("A" & Rows.Count).End(3))
    If c.Offset(, 1) >= CDate(TextBox1) And c.Offset(, 1) <= CDate(TextBox2) Then
      Set f = rng2.Find(c, , xlValues, xlWhole)
      If Not f Is Nothing Then f.Offset(, Month(c.Offset(, 1))) = f.Offset(, Month(c.Offset(, 1))) + c.Offset(, 4)
    End If
  Next
  Application.ScreenUpdating = True
End Sub

Prueba las dos macros y me comentas.

En ambas macros van los filtros por fechas en los textbox1 y textbox2.

Si tienes dudas con todo gusto te puedo ayudar, solamente comenta cuál es tu pregunta.

ok

creo que ya le atine,

gracias por la ayuda

saludos