Consolidar datos según el mes con vba?
Dispongo de tres hojas en un archivo, en la hoja1 están los datos únicos con id, en la hoja2 hay registros de los id con valores y fechas diferentes, la hoja3 consolida los datos según el id por mes. Necesito su ayuda para que me consolide la información según el mes que corresponda por el id, según las imágenes adjuntas
Con este código me funciona solo para un mes especifico.
For i = 10 To h1.Range("B" & Rows.Count).End(xlUp).Row
If Month(h1.Cells(i, "Y").Value) >= Month(h1.Cells(i + 1, "Y").Value) And Month(h1.Cells(i, "Y").Value) <= Month(h1.Cells(i + 1, "Y").Value) Then
Set b = h2.Columns("B").Find(h1.Cells(i, "B").Value, lookat:=xlWhole)
If Not b Is Nothing Then
h2.Cells(b.Row, "D").Value = h2.Cells(b.Row, "D").Value + h1.Cells(i, "D").Value
Else
u2 = h2.Range("B" & Rows.Count).End(xlUp).Row + 1
h2.Cells(u2, "A").Value = h1.Cells(i, "A").Value
h2.Cells(u2, "B").Value = h1.Cells(i, "B").Value
1 Respuesta
La siguiente macro funciona de acuerdo a las posiciones de los datos mostrados en tus imágenes, es decir:
Los datos en la Hoja1 empiezan en la celda A2.
Los datos en la Hoja2 empiezan en la celda A2.
Y el resultado en la Hoja3 iniciando en la celda A2.
NOTAS:
1. No está claro cuál fecha se debe poner en la Hoja3.
Para septiembre pusiste 30/09/2021, pero esta fecha no existe en la Hoja2.
Mientras que para octubre pusiste 30/10/2021.
Como es un acumulado por mes, necesitas poner una sola fecha, puede ser el primer día del mes, el último día del mes o cualquier fecha de las que están en la Hoja2 que corresponda al mes.
En la macro te puse el último día del mes.
2. Si el ID de la Hoja2, no existe en la Hoja1, entonces los datos SEC y Nombre serán tomados de la misma Hoja2.
3. Tampoco está en tu ejemplo qué debe ponerse en la columna de Observaciones. En la macro te va a poner la última observación del mes.
Supongo que van a existir algunos ajustes a la macro. Pero realiza la pruebas considerando mis notas.
Sub ConsolidarPorMes()
Dim a As Variant, b As Variant, c As Variant
Dim dic1 As Object, dic2 As Variant
Dim llave As String
Dim i As Long, j As Long, k As Long
'
a = Sheets("Hoja1").Range("A2", Sheets("Hoja1").Range("C" & Rows.Count).End(3)).Value
b = Sheets("Hoja2").Range("A2", Sheets("Hoja2").Range("T" & Rows.Count).End(3)).Value
ReDim c(1 To UBound(b, 1), 1 To UBound(b, 2))
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
'
For i = 1 To UBound(a, 1)
dic1(a(i, 2)) = a(i, 1) & "|" & a(i, 3)
Next
'
For i = 1 To UBound(b, 1)
llave = b(i, 2) & "|" & Month(b(i, 20))
If Not dic2.exists(llave) Then
j = j + 1
dic2(llave) = j
Else
j = dic2(llave)
End If
For k = 1 To UBound(b, 2)
Select Case k
Case 1, 3 'SEC | NOMBRE
If dic1.exists(b(i, 2)) Then
c(j, 1) = Split(dic1(b(i, 2)), "|")(0)
c(j, 3) = Split(dic1(b(i, 2)), "|")(1)
Else
c(j, k) = b(i, k)
End If
Case 2 'ID
c(j, k) = b(i, k)
Case 19 'OBS
If b(i, k) <> "" Then c(j, k) = b(i, k)
Case 20 'fecha
'Último día del mes
c(j, k) = DateSerial(Year(b(i, 20)), Month(b(i, 20)) + 1, 1) - 1
Case Else 'VR
c(j, k) = c(j, k) + b(i, k)
End Select
Next
Next
Sheets("Hoja3").Range("A2").Resize(dic2.Count, UBound(c, 2)).Value = c
End Sub
wow, que poder de ejecución y rapidez lo uso de los diccionarios en vba. La verdad eres todo un experto AAA ingeniero Dante Amor. Felicitaciones y Dios te cuide y te siga dando esa sabiduría que compartes en este canal de la manera más noble. - Paco Machuca
Soy algo novato pero seguí la pregunta junta con la respuesta y es una maravilla. Genial - Wilson Simón
Gracias por tus comentarios Paco. - Dante Amor
Hola Wilson. Gracias por los comentarios. - Dante Amor