Saltar al contenido

Macro para sumar valores de varias columnas que correspondan a un mismo valor de otra columna


Recommended Posts

publicado

Hola tengo esta macro si me funciona pero me pregunto si hay manera de modificarla y no repita las lineas de código ya que necesito que se haga la búsqueda hasta la columna DL

Tengo una serie de datos mas o menos asi:

A__M__N__DK__DL

1__4__5__2___3

3__6__7__6___1

3__2__6__12__11

4__1__1__4___9

7__3__2__13__32

9__3__5__7___5

9__2__4__3___90

DP_DQ_DR_DS_DT

1__4__9__11_14

3__8__21_39_51

4__1__2__6__15

7__3__5__18_50

9__5__14_24_119

Sub sumarsi()

Application.ScreenUpdating = False

Dim uf As Long, uf2 As Long

Dim rangocriterio As Range

Dim rangosuma1 As Range

Dim rangosuma2 As Range

Dim rangosuma3 As Range

uf = Range("A" & Rows.Count).End(xlUp).Row

Range("A1:A" & uf).AdvancedFilter 2, CriteriaRange, Range("DP1"), Unique:=True 'CAMBIO

Set rangocriterio = Range("A2:A" & uf)

Set rangosuma1 = Range("M2:M" & uf)

Set rangosuma2 = Range("N2:N" & uf)

Set rangosuma3 = Range("O2:O" & uf)

'********************************+

Set rangosuma4 = Range("P2:P" & uf)

Set rangosuma5 = Range("Q2:Q" & uf)

Set rangosuma6 = Range("R2:R" & uf)

Set rangosuma7 = Range("S2:S" & uf)

Set rangosuma8 = Range("T2:T" & uf)

Set rangosuma9 = Range("U2:U" & uf)

Set rangosuma10 = Range("V2:V" & uf)

Set rangosuma11 = Range("W2:W" & uf)

Set rangosuma12 = Range("X2:X" & uf)

Set rangosuma13 = Range("Y2:Y" & uf)

Set rangosuma14 = Range("Z2:Z" & uf)

Set rangosuma15 = Range("AA2:AA" & uf)

Range("DQ1") = Range("M1"): Range("DR1") = Range("N1"): Range("DS1") = Range("O1"): Range("DT1") = Range("P1"): Range("DU1") = Range("Q1"): Range("DV1") = Range("R1")

Range("DW1") = Range("S1"): Range("DX1") = Range("T1"): Range("DY1") = Range("U1"): Range("DZ1") = Range("V1"): Range("EA1") = Range("W1"): Range("EB1") = Range("X1")

'CAMBIOFILA 1

uf2 = Range("DP" & Rows.Count).End(xlUp).Row 'CAMBIO AQUÍ

With Range("DQ2:DQ" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma1.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("DR2:DR" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma2.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

'********+PRUEBA D

With Range("DS2:DS" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma3.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

'***********************************************************

With Range("DT2:DT" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma4.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("DU2:DU" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma5.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("DV2:DV" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma6.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("DW2:DW" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma7.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("DX2:DX" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma8.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("DY2:DY" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma9.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("DZ2:DZ" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma10.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("EA2:EA" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma11.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("EB2:EB" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma12.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("EC2:EC" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma13.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("ED2:ED" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma14.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

With Range("EE2:EE" & uf2) 'CAMBIO AQUÍ

.Formula = "=SUMIF(" & rangocriterio.Address & ", $DP2 ," & rangosuma15.Address & ")" 'CAMBIO AQUÍ

.Formula = .Value

End With

' FIN DE PRUEBA

Set rangocriterio = Nothing

Set rangosuma1 = Nothing

Set rangosuma2 = Nothing

Set rangosuma3 = Nothing

Set rangosuma4 = Nothing

Set rangosuma5 = Nothing

Set rangosuma6 = Nothing

Set rangosuma7 = Nothing

Set rangosuma8 = Nothing

Set rangosuma9 = Nothing

Set rangosuma10 = Nothing

Set rangosuma11 = Nothing

Set rangosuma12 = Nothing

Set rangosuma13 = Nothing

Set rangosuma14 = Nothing

Set rangosuma15 = Nothing

Application.ScreenUpdating = True

End Sub

Gracias por su ayuda

ayuda1.zip

publicado

ola, lo mas practico es usar la herramienta CONSOLIDAR de excel, con o sin macros.

1. Asigna un titulo diferente a cada columna: Datos1, Datos2, etc.

2. Selecciona A19, segun tu ejemplo

3. Selecciona en la barra Datos/Consolidar y:

a) Suma

B) Referencia "A1:p8", sin comillas - en vez del icono deber ser 2 puntos y P8

c) Usar Rotulos en fila superior y columna izquierda

4. OK

Si lo haces con la grabadora encendida obtendras el codigo que depurare cuando lo publiques/subas.

Al publicar codigos debes usar etiquetas, revisa por favor las normas del foro.

Aqui un ejemplo ilustrado:

Consolidar valores de filas

publicado

Muchas gracias por la información tengo otra duda

Tengo una serie de datos mas o menos asi:

A__M__N__DK__DL

1__4__5__2___3

3__6__7__6___1

3__2__6__12__11

4__1__1__4___9

7__3__2__13__32

9__3__5__7___5

9__2__4__3___90

DP_DQ_DR__DS_DT

1___4___5___2__3

3___8___13__18_12

4___1___1___4__9

7___3___2___3__32

9___5___9__10_95

Lo que gustaria es hacer la suma fila consecutivas quedando asi el resultado

DP___DQ___DR__DS___DT

1____4____9____11____14

3____8____21___39____51

4____1____2____6_____15

7____3____5____18____50

9____5____14___24____119

Espero sus respuestas

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

  • 109 ¿Te parecen útiles los tips de las funciones? (ver tema completo)

    1. 1. ¿Te parecen útiles los tips de las funciones?


      • No
      • Ni me he fijado en ellos

  • Ayúdanos a mejorar la comunidad

    • Donaciones recibidas este mes: 0.00 EUR
      Objetivo: 130.00 EUR
  • Archivos

  • Estadísticas de descargas

    • Archivos
      187
    • Comentarios
      97
    • Revisiones
      29

    Más información sobre "Un juego del Rabino en Excel"
    Última descarga
    Por pegones1

    2    1

  • Crear macros Excel

  • Mensajes

    • Que tal nuevamente,  adjunto una solución alternativa: =MAX(A:.A)-BYROW(F4:.AK20,LAMBDA(r,BUSCAR(2,1/(r=0),F3:.AK3))) Cabe mencionar que esta solución requiere funciones nuevas como RECORTAR.RANGO. CONTADOR FINAL (Solucion).xlsb
    • Buenos días,  espero se encuentren bien de salud compañeros, Favor me podrían ayuda con lo siguientes como se podría hacer cuando tengo una tabla dinámica que  amedida que se aumente las columnas fechas con data un formula que se coloco al final busque o analice siempre la ultima fila y columna de la fecha. Coloco un ejemplo
    • @JSDJSD Excelentes, GRACIAS POR TU SOPORTE , me ayudo demasiado es exactamente lo que quería. 5 ESTRELLAS
    • 'Opción 1 Sub FiltrarSKUPorFecha(): Application.ScreenUpdating = False Dim ultimaFila As Long, fila As Long Dim diccionarioSKU As Object Dim listaEliminar As Object Dim fechaActual As String, fechaSiguiente As String Dim f As Variant With Sheets("Consolidado") ultimaFila = .Cells(.Rows.Count, 1).End(xlUp).Row ' Crear diccionarios para comparar SKU y almacenar filas a eliminar Set diccionarioSKU = CreateObject("Scripting.Dictionary") Set listaEliminar = CreateObject("Scripting.Dictionary") ' Recorrer desde la primera fila hasta la penúltima For fila = 2 To ultimaFila - 1 fechaActual = .Cells(fila, 1).Value fechaSiguiente = .Cells(fila + 1, 1).Value ' Solo comparar la fecha actual con la siguiente (inmediatamente superior) If fechaActual <> fechaSiguiente Then diccionarioSKU.RemoveAll ' Limpiar el diccionario antes de llenarlo ' Guardar los SKU de la fecha siguiente (solo de la siguiente) For f = fila + 1 To ultimaFila If .Cells(f, 1).Value <> fechaSiguiente Then Exit For diccionarioSKU(.Cells(f, 2).Value) = 1 Next f ' Revisar los SKU de la fecha actual y marcar los que deben eliminarse For f = fila To 2 Step -1 If .Cells(f, 1).Value <> fechaActual Then Exit For ' Solo eliminar si el SKU no está en la fecha siguiente If Not diccionarioSKU.exists(.Cells(f, 2).Value) Then listaEliminar(f) = 1 ' Marcar fila para eliminar después End If Next f ' Ya no es necesario seguir buscando después de comparar la primera y la siguiente fecha Exit For End If Next fila ' Eliminar las filas marcadas sin afectar el bucle principal For Each f In listaEliminar.keys .Rows(f).Delete Next End With MsgBox "Completado correctamente.", vbInformation End Sub 'Opción 2 Sub FiltrarSKUPorFecha1(): Application.ScreenUpdating = False Dim ultimaFila As Long, fila As Long Dim listaEliminar As Collection Dim fechaActual As String, fechaSiguiente As String Dim f As Variant, i As Long Dim SKUExiste As Boolean With Sheets("Consolidado") ultimaFila = .Cells(.Rows.Count, 1).End(xlUp).Row ' Inicializar la colección para marcar las filas a eliminar Set listaEliminar = New Collection ' Recorrer desde la primera fila hasta la penúltima For fila = 2 To ultimaFila - 1 fechaActual = .Cells(fila, 1).Value fechaSiguiente = .Cells(fila + 1, 1).Value ' Solo comparar la fecha actual con la siguiente (inmediatamente superior) If fechaActual <> fechaSiguiente Then ' Revisar los SKU de la fecha actual y marcar los que deben eliminarse For f = fila To 2 Step -1 If .Cells(f, 1).Value <> fechaActual Then Exit For ' Comprobar si el SKU está en la fecha siguiente SKUExiste = False For i = fila + 1 To ultimaFila If .Cells(i, 1).Value <> fechaSiguiente Then Exit For If .Cells(i, 2).Value = .Cells(f, 2).Value Then SKUExiste = True Exit For End If Next i ' Si el SKU no se encuentra en la fecha siguiente, marcar para eliminar If Not SKUExiste Then listaEliminar.Add f ' Marcar fila para eliminar después End If Next f ' Ya no es necesario seguir buscando después de comparar la primera y la siguiente fecha Exit For End If Next fila ' Eliminar las filas marcadas sin afectar el bucle principal For Each f In listaEliminar .Rows(f).Delete Next f End With MsgBox "Completado correctamente.", vbInformation End Sub   TABLA ELIMINAR.xlsm
  • Visualizado recientemente

    • No hay usuarios registrado para ver esta página.
×
×
  • Crear nuevo...

Información importante

Echa un vistazo a nuestra política de cookies para ayudarte a tener una mejor experiencia de navegación. Puedes ajustar aquí la configuración. Pulsa el botón Aceptar, si estás de acuerdo.