Macro que copie datos con especificaciones
Supongase que tengo 3 columnas como las que aparecen
en la imagen. La columna A1 se llama NUMERO, la columna B1 se llama DESCRIPCIÓN y la columna C1 se llama valores. Necesito una macro que elimine los datos repetidos de la columna B1, pero los sume en una sola casilla; a demás que coincida los datos de la columna A1 y B1 en las celdas E1 y F1 respectivamente.
2 respuestas
Respuesta de Adriel Ortiz Mangia
1
[Hola
prueba con esto
Sub Macro1()
'
' AOM
Application.ScreenUpdating = False
Columns("E:G").ClearContents
Range("A1:B100").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("E1" _
), Unique:=True
Range("G1") = Range("C1")
With Range("G2:G" & Range("E2:E" & Rows.Count).End(xlDown).Row)
.FormulaR1C1 = "=SUMIF(RC[-6]:R[4]C[-6],RC[-2],RC[-4]:R[4]C[-4])"
.Value = .Value
End With
Application.ScreenUpdating = True
MsgBox "fin"
End Sub
Respuesta de James Bond
1
El resultado de la macro, de un lado coloca los nombres sin repetición y elimina todos los repetidos, del otro lado coloca los que tienen repeticiones con su suma
Y esta es la macro
Option Base 1
Sub FILTRARYELIMINAR()
Set datos = Range("A1").CurrentRegion
With datos
filas = .Rows.Count: COL = .Columns.Count
Set datos = .Rows(2).Resize(filas - 1, COL)
.Copy
.Columns(COL + 2).PasteSpecial
.Columns(COL + 2).CurrentRegion.RemoveDuplicates Columns:=2
ReDim matriz(filas, 3)
ReDim matriz2(filas, 3)
Set tabla = .Columns(COL + 2).CurrentRegion
XFILAS = tabla.Rows.Count
X = 1: Y = 1
For I = 1 To XFILAS
NOMBRE = tabla.Cells(I, 2)
CUENTA = WorksheetFunction.CountIf(.Columns(2), NOMBRE)
SUMA = WorksheetFunction.SumIf(.Columns(2), NOMBRE, .Columns(3))
If CUENTA = 1 Then
matriz(X, 1) = .Cells(I, 1)
matriz(X, 2) = NOMBRE
matriz(X, 3) = .Cells(I, 3)
X = X + 1
Else
matriz2(Y, 1) = tabla.Cells(I, 1)
matriz2(Y, 2) = NOMBRE
matriz2(Y, 3) = SUMA
Y = Y + 1
End If
Next I
.Clear
.Range(.CurrentRegion.Resize(filas, 3).Address) = matriz
With tabla
.ClearContents
Range(Range("E2").Resize(filas, 3).Address) = matriz2
End With
End With
Erase matriz: Erase matriz2
Set datos = Nothing: Set tabla = Nothing
End Sub