Macro para desglosar por mes
------------
Para Dante Amor
Buena noche
Con una molestia
Haceme el favor de cambiarme algunas lineas del codigo
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(cond1) And a(i, 2) <= CDate(cond2) 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 Subfunciona perfecto, pero quiero hacer que desgloce los meses asi como se ve en la imagen
Solo es la posicion de los meses, que no estan corridos,
Los meses estan en las columnas amarillas, enero, febrero, marzo y abril en las columnas c, d, e y f
Mayo, junio, julio y agosto en las columnas j, k, l y m
Y septiembre, octubre, noviembre y diciembre en las columnas q, r, s, t
Todo en la hoja cuatri
En las otras columnas (b, g, h, i, n, o, p, u, v, w) tengo formulas, alli no debe cambiar nada.
1 respuesta
Te respondí la pregunta. Deberías ser un poco más paciente, tal vez alguien más te pueda ayudar, pero está del otra lado del mundo.
Va nuevamente la macro para que la consideres.
Private Sub CommandButton1_Click()
'Por Dante Amor
'DECLARACIÓN de variables
Dim a As Variant, b As Variant, c1 As Variant, c2 As Variant, c3 As Variant
Dim dic As Object, i As Long, j As Long, k As Long, sh As Worksheet
'ENTRADAS
Set sh = Sheets("Cuatri")
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 = sh.Range("A3", sh.Range("A" & Rows.Count).End(3)).Value2
ReDim c1(1 To UBound(b), 1 To 4)
ReDim c2(1 To UBound(b), 1 To 4)
ReDim c3(1 To UBound(b), 1 To 4)
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))
Select Case k
Case 1 To 4: c1(j, k) = c1(j, k) + a(i, 5)
Case 5 To 8: c2(j, k - 4) = c2(j, k - 4) + a(i, 5)
Case 9 To 12: c3(j, k - 8) = c3(j, k - 8) + a(i, 5)
End Select
End If
Next
'SALIDA
sh.Range("C3").Resize(UBound(c1, 1), 4).Value = c1
sh.Range("J3").Resize(UBound(c2, 1), 4).Value = c2
sh.Range("Q3").Resize(UBound(c3, 1), 4).Value = c3
End SubNo realicé demasiadas pruebas, así que deberás realizar todas las pruebas posibles y si requieres algo más, tendrás que precisar lo necesario para entender el problema y poder ayudarte.
buena noche
disculpa
volvi a hacer la pregunta pero con unos detalles y la otro trate de eliminarla pero no se elimino
ya probé el codigo y funciona bien
te agradezco todo
Me alegra ayudarte ! Gracias! Por comentar
Gracias mi amigo Dante Amor, si veo que usaste el objeto diccionario, que bueno y excelente para seguir aprendiendo más de su funcionalidad. Mil gracias - Francisco Jaimes