Macro que identifique y sume filas con características en común
Tengo un reporte del sistema de mi trabajo que arroja los resultados de partidas de un plan de cuentas. Cada partida está en una tabla. A su vez cada partida tiene composiciones donde aparecen los montos que quiero sumar.
Quiero unificar partidas con características similares. Por ejemplo: "MANTENIMIENTO - TRAMO I" y la partida "MANTENIMIENTO - TRAMO II" aparecen en distintos lugares en la Hoja 1. La idea es una macro que identifique estas partidas similares y unifique los montos en una sola partida que puede llevar por nombre cualquiera de las mismas. Las composiciones que no esten en las dos y sólo en una, también deberán ser incluidas. Y luego elimine las tablas de estas partidas que ya han sido unificadas.
Cada partida tiene un código. Asímismo, las composiciones de cada partida.
Yo tengo una lista en la Hoja 2 con los códigos de las partidas que quisiera unificar. Porque no son todas. Pero igual son bastantes.
2 Respuestas
Sub Acceder1()
Set h1 = Sheets(1)
Set h2 = Sheets(2)
Dim P1 As Object
Dim P2 As Object
Dim f1, f2, x, Finf1, Finf2 As Integer
For i = 2 To h2.Range("A" & Rows.Count).End(xlUp).Row
Set P1 = h1.Range("C:C").Find(h2.Cells(i, 1).Value)
Set P2 = h1.Range("C:C").Find(h2.Cells(i, 2).Value)
If Not P1 Is Nothing And Not P2 Is Nothing Then
'*****Encontrar Fila final de la Tabla1************
f1 = P1.Row
x = 5
Do Until Cells(f1 + x, 7).Value = "Total Geral"
If Cells(f1 + x + 1, 7).Value = "Total Geral" Then Finf1 = f1 + x
x = x + 1
Loop
'*****Encontrar Fila final de la Tabla2************
f2 = P2.Row
x = 5
Do Until Cells(f2 + x, 7).Value = "Total Geral"
If Cells(f2 + x + 1, 7).Value = "Total Geral" Then Finf2 = f2 + x
x = x + 1
Loop
If f2 > f1 Then
Cells(f1, 3).Value = h2.Cells(i, 4).Value '********Colocación de Código Final************
'*****Suma de Volumenes previstos de Partidas************
For j = 9 To 33
Cells(f1 + 1, j).Value = Cells(f2 + 1, j).Value + Cells(f1 + 1, j).Value
Next
'*****Suma de Valores comunes************
For k = f1 + 5 To Finf1
For l = f2 + 5 To Finf2
If Cells(k, 4).Value = Cells(l, 4).Value And Cells(k, 4).Value <> "" Then
For j = 9 To 33
Cells(k, j).Value = Cells(l, j).Value + Cells(k, j).Value
Next
End If
Next
Next
'*****Identificacion de filas que no están y posterior mover************
For l = f2 + 5 To Finf2
With Worksheets(1).Range(Cells(f1 + 5, 4), Cells(Finf1, 4))
Set c = .Find(Cells(l, 4).Value, LookIn:=xlValues)
If c Is Nothing Then
Cells(l, 4).Select
Selection.End(xlToLeft).End(xlToLeft).End(xlUp).Select
If ActiveCell.Value = "Insumos" Then
Rows(l).Cut
Rows(f1 + 5).Insert Shift:=xlDown
Finf1 = Finf1 + 1
f2 = f2 + 1
Else
Rows(l).Cut
Rows(Finf1 + 1).Insert Shift:=xlDown
Finf1 = Finf1 + 1
f2 = f2 + 1
End If
End If
End With
Next
'*************Eliminación de Tablas que ya han sido unificadas************
Range(Cells(f2, 3), Cells(Finf2 + 1, 3)).EntireRow.Delete
Else ' ***se aplica lo inverso
Cells(f2, 3).Value = h2.Cells(i, 4).Value '********Colocación de Código Final************
'*****Suma de Volumenes previstos de Partidas************
For j = 9 To 33
Cells(f2 + 1, j).Value = Cells(f1 + 1, j).Value + Cells(f2 + 1, j).Value
Next
'*****Suma de Valores comunes***********
For k = f2 + 5 To Finf2
For l = f1 + 5 To Finf1
'*********Suma de valores*********
If Cells(k, 4).Value = Cells(l, 4).Value And Cells(k, 4).Value <> "" Then
For j = 9 To 33
Cells(k, j).Value = Cells(l, j).Value + Cells(k, j).Value
Next
End If
Next
Next
For l = f1 + 5 To Finf1
'*****Identificacion de filas que no están************
With Worksheets(1).Range(Cells(f2 + 5, 4), Cells(Finf2, 4))
Set c = .Find(Cells(l, 4).Value, LookIn:=xlValues)
If c Is Nothing Then
Cells(l, 4).Select
Selection.End(xlToLeft).End(xlToLeft).End(xlUp).Select
If ActiveCell.Value = "Insumos" Then
Rows(l).Cut
Rows(f2 + 5).Insert Shift:=xlDown
Finf2 = Finf2 + 1
f1 = f1 + 1
Else
Rows(l).Cut
Rows(Finf2 + 1).Insert Shift:=xlDown
Finf2 = Finf2 + 1
f1 = f1 + 1
End If
End If
End With
Next
'*************Eliminación de Tablas que ya han sido unificadas************
Range(Cells(f1, 3), Cells(Finf1 + 1, 3)).EntireRow.Delete
End If
End If
Next
Call CodigosUnitarios
MsgBox "Macro ejecutada con éxito"
End Sub
Sub CodigosUnitarios()
Set h1 = Sheets(1)
Set h3 = Sheets(3)
Dim P3 As Object
Dim f3, cont As Integer
cont = 1
For i = 2 To h3.Range("A" & Rows.Count).End(xlUp).Row
Set P3 = h1.Range("C:C").Find(h3.Cells(i, 1).Value)
If Not P3 Is Nothing Then
f3 = P3.Row
Cells(f3, 3).Value = h3.Cells(i, 2).Value
cont = cont + 1
End If
Next
MsgBox "Macro ejecutada con éxito y con " & cont & " iteraciones"
End Sub
Para desarrollarte una macro se necesitan más referencias, es decir ubicación y nombre de los datos. Tendrás que subir tu hoja en algún sitio o enviamela a mi correo (aparece en la portada de mi sitio).
Desde ya te aclaro que que Excel no tiene cómo identificar los 'similares' salvo que nosotros se lo indiquemos. No olvides adjuntar la tabla con los códigos unificados.
Sdos
Elsa