Macro para agrupar y sumar registros con varios criterios
En la tabla de datos la columna E, G, I, J, L y M corresponde a ID únicos y en las columnas N y P hay dos criterios que se deben asociar a cada registro de los ID, para luego sumar los valores de las columnas Q, R, S, T, U y V según la combinación de los IDs con los criterios N y P .Cada ID tiene asignado un valor, es decir el ID EP (Columna E) va con el valor de EP (columna Q), cada registro tiene un centro de costos y grupo.
Sub sumarSS()
'Por Dante Amor
Set h11 = Sheets("REGSS")
Set h14 = Sheets("Hoja1")
h14.Cells.ClearContents
h11.[B9:AB9].Copy h14.[B9]
h14.[A9] = "REG"
r = 1
For i = 10 To h11.Range("E" & Rows.Count).End(xlUp).Row
Set s = h14.Columns("E").Find(h11.Cells(i, "E").Value, lookat:=xlWhole)
If Not s Is Nothing Then
h14.Cells(s.Row, "Q").Value = h14.Cells(s.Row, "Q").Value + h11.Cells(i, "Q").Value
Else
u1 = h14.Range("A" & Rows.Count).End(xlUp).Row + 1
h14.Cells(u1, "A").Value = r
h14.Cells(u1, "E").Value = h11.Cells(i, "E").Value
h14.Cells(u1, "F").Value = h11.Cells(i, "F").Value
h14.Cells(u1, "Q").Value = h11.Cells(i, "Q").Value
r = r + 1
End If
Next
For h = 10 To h11.Range("G" & Rows.Count).End(xlUp).Row
Set p = h14.Columns("G").Find(h11.Cells(h, "G").Value, lookat:=xlWhole)
If Not p Is Nothing Then
h14.Cells(p.Row, "R").Value = h14.Cells(p.Row, "R").Value + h11.Cells(h, "R").Value
Else
u2 = h14.Range("A" & Rows.Count).End(xlUp).Row + 1
h14.Cells(u2, "A").Value = r
h14.Cells(u2, "G").Value = h11.Cells(h, "G").Value
h14.Cells(u2, "H").Value = h11.Cells(h, "H").Value
h14.Cells(u2, "R").Value = h11.Cells(h, "R").Value
r = r + 1
End If
Next
Next
End Sub
'Ajuste el código de una pregunta anterior, y funciona bien,
'solo que esta vez tiene que tener en cuenta los criterios mencionados.
1 Respuesta
Respuesta de Dante Amor
2
Te anexo la macro
Sub Sumar_Nits()
'Por Dante Amor
Application.ScreenUpdating = False
Set h1 = Sheets("Hoja1")
Set h2 = Sheets("Hoja2")
h2.Rows("2:" & Rows.Count).ClearContents
u = h1.Range("D" & Rows.Count).End(xlUp).Row
k = 2
c1s = Array("E", "G", "I", "J", "L", "M")
c2s = Array("Q", "R", "S", "T", "U", "V")
c3s = Array("F", "H", " ", "K", " ", " ")
For c = LBound(c1s) To UBound(c1s)
With h1.Sort
.SortFields.Clear
.SortFields.Add Key:=h1.Range("D2:D" & u)
.SortFields.Add Key:=h1.Range(c1s(c) & "2:" & c1s(c) & u)
.SortFields.Add Key:=h1.Range("N2:N" & u)
.SortFields.Add Key:=h1.Range("O2:O" & u)
.SetRange h1.Range("A1:V" & u): .Header = xlYes: .MatchCase = False
.Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
End With
'
an1 = h1.Cells(2, "D")
an2 = h1.Cells(2, c1s(c))
an3 = h1.Cells(2, "N")
an4 = h1.Cells(2, "O")
If c3s(c) <> " " Then ant = h1.Cells(2, c3s(c))
wsuma = 0
For i = 2 To u + 1
If an1 <> h1.Cells(i, "D") Or _
an2 <> h1.Cells(i, c1s(c)) Or _
an3 <> h1.Cells(i, "N") Or _
an4 <> h1.Cells(i, "O") Then
h2.Cells(k, "D") = an1
h2.Cells(k, c1s(c)) = an2
If c3s(c) <> " " Then h2.Cells(k, c3s(c)) = ant
h2.Cells(k, "N") = an3
h2.Cells(k, "O") = an4
h2.Cells(k, c2s(c)) = wsuma
k = k + 1
wsuma = 0
End If
an1 = h1.Cells(i, "D")
an2 = h1.Cells(i, c1s(c))
an3 = h1.Cells(i, "N")
an4 = h1.Cells(i, "O")
If c3s(c) <> " " Then ant = h1.Cells(i, c3s(c))
wsuma = wsuma + h1.Cells(i, c2s(c))
Next i
Next c
u2 = h2.Range("D" & Rows.Count).End(xlUp).Row
With h2.Sort
.SortFields.Clear
.SortFields.Add Key:=h2.Range("D2:D" & u2)
.SetRange h2.Range("A1:V" & u2): .Header = xlYes: .MatchCase = False
.Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
End With
'
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub[Sal u dos. No olvides valorar.
