Como extraer filas con condición de una hoja de Excel y copiarlas en otras hojas (pero que sume sub totales)
Para dante amor amigo este es la continuación de la pregunta anterior
"
Hoja1) con mucha data son 1,400 filas en 8 columnas que tiene encabezados. Lo que quiero es que cuando le de click en un botón copie todas las filas que tengan el mismo número de la columna A (A2:A1400 son códigos hay varios) en la columna A1:H1 están los encabezados que también quiero que los copie en otra hoja, pero solo quiero que los filtre si los códigos cumplen y que además copie los códigos,
Y para terminar quiero por cada código cree una hoja nueva y esa hoja tendrá como nombre el numero del código quiero que se cree tantas hojas como códigos encuentre
"
Y además que sume sub totales y sace la diferencia
1 respuesta
Respuesta de Dante Amor
1
H o l a:
Te anexo la macro para poner los subtotales
Sub GenerarCorreos()
'Por.Dante Amor
Application.ScreenUpdating = False
Set l1 = ThisWorkbook
Set h1 = l1.Sheets("BASE DATOS")
Set h2 = l1.Sheets("Temp")
Call BorrarHojas
'
If h1.AutoFilterMode Then h1.AutoFilterMode = False
h2.Cells.Clear
u1 = h1.Range("A" & Rows.Count).End(xlUp).Row
h1.Range("I" & u1 + 2).FormulaR1C1 = "=SUBTOTAL(9,R2C:R[-2]C)"
h1.Range("J" & u1 + 2).FormulaR1C1 = "=SUBTOTAL(9,R[-1538]C:R[-2]C)"
h1.Range("J" & u1 + 3).FormulaR1C1 = "=R[-1]C[-1]-R[-1]C"
'
h1.Columns("H").Copy h2.[A1]
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
h2.Range("A1:A" & u2).RemoveDuplicates Columns:=1, Header:=xlYes
'
u2 = h2.Range("A" & Rows.Count).End(xlUp).Row
With h2.Sort
.SortFields.Clear
.SortFields.Add Key:=h2.Range("A2:A" & u2), _
SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortTextAsNumbers
.SetRange h2.Range("A1:A" & u2): .Header = xlYes: .MatchCase = False
.Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
End With
'
For i = 2 To h2.Range("A" & Rows.Count).End(xlUp).Row
h1.Range("A1:H" & u1).AutoFilter Field:=8, Criteria1:=h2.Cells(i, "A")
h1.Range("A1:J" & u1 + 3).Copy
Set h3 = Sheets.Add(after:=Sheets(Sheets.Count))
h3.[A1].PasteSpecial xlValues
h3.[A1].PasteSpecial xlFormats
u3 = h3.Range("A" & Rows.Count).End(xlUp).Row + 1
h3.Rows(u3).Delete
h3.Name = h2.Cells(i, "A")
Next
If h1.AutoFilterMode Then h1.AutoFilterMode = False
h1.Range(h1.Cells(u1 + 2, "I"), h1.Cells(u1 + 3, "J")).Clear
h1.Select
Application.ScreenUpdating = False
MsgBox "Fin"
End Sub
'
Sub BorrarHojas()
'Por.Dante Amor
Application.DisplayAlerts = False
For h = Sheets.Count To 3 Step -1
Sheets(h).Delete
Next
End Sub'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
