Macro para desglosar por cuatrimestre
------------
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
Siempre con fecha inicial y fecha final
Lo que pasa es que introduje formulas cada cuatro meses para evaluar por cuatrimestre
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
Según la imagen los resultados empiezan en C3, J3 y A3.
Prueba la siguiente:
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 Sub
Me podrías suministrar el archivo de ejemplo para practicar el código - Francisco Jaimes