Macro Unir filas de tablas con código similar en una sola tabla
Tengo varias tablas dentro de una hoja con un código asignado para cada una. Hay códigos que se repiten para más de dos tablas. Quisiera una macro que una las filas de todas estas tablas con código común en una sola tabla y se le asigne el mismo código.
Dentro de las tablas hay filas que tienen, a su vez, códigos similares. Estos habría que sumarlos, y los que son únicos, moverlos a la tabla final.
Respuesta de Juan Chero
1
Sub prueba()
Dim values(1 To 21) As Double
Dim filas(1 To 2) As Integer
Dim j As Integer
values(1) = 1.02
values(2) = 2.01
values(3) = 2.03
values(4) = 2.05
values(5) = 2.07
values(6) = 3.01
values(7) = 4.02
values(8) = 4.03
values(9) = 6.01
values(10) = 6.03
values(11) = 6.04
values(12) = 6.07
values(13) = 6.08
values(14) = 6.09
values(15) = 6.11
values(16) = 6.14
values(17) = 7.02
values(18) = 7.05
values(19) = 8.01
values(20) = 9.02
values(21) = 9.03
For I = 1 To 21
j = 1
For Each c In Range("C1:C" & Cells(Rows.Count, 7).End(xlUp).Row)
If c = values(I) Then
filas(j) = c.Row
If j = 2 Then
Call Unir(filas(1), filas(2))
j = 1
End If
j = j + 1
End If
Next c
For j = 1 To 2 '****limpiamos el array
filas(j) = 0
Next
Next
MsgBox "fin"
End Sub
Sub Unir(ByVal f1 As Integer, ByVal f2 As Integer)
Dim x, Finf1, Finf2 As Integer
'*****Encontrar Fila final de la Tabla1************
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************
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
'*****Suma de Volumenes previstos de Partidas************
For j = 9 To 33
Cells(f1 + 1, j).Select
With Selection
.Value = ""
.Borders.LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlContinuous
End With
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
If Cells(k, j).Value = 0 Then 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(3).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
'*****Suma de Volumenes previstos de Partidas************
For j = 9 To 33
Cells(f2 + 1, j).Select
With Selection
.Value = ""
.Borders.LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlContinuous
End With
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
If Cells(k, j).Value = 0 Then Cells(k, j).Value = ""
Next
End If
Next
Next
For l = f1 + 5 To Finf1
'*****Identificacion de filas que no están************
With Worksheets(3).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 Sub
