Hola, que se encuentren bien.
Tengo este codigo que me suministro un amigo de acá de la pagina mrExcel.com pero se encuentra un poco enfermo y no quiero molestarlo (por ahora)
Sub Llenar_Con_Totales()
Dim RangoTotales As Range, Totales(), Totales_X_Año(), t As Range, x As Range
Dim Cuenta As Integer, i As Integer, LrA1 As Integer, LrA2 As Integer
Dim r As Integer, c As Integer, XCelda As Range
'#1 Llenar arreglo con líneas totales (en rojo) de la hoja FacturaN
With Sheets("Factura1")
LrA1 = .Range("B65000").End(xlUp).Row: LrA2 = .Range("I65000").End(xlUp).Row
Set RangoTotales = Union(.Range("B2:B" & LrA1), .Range("I2:I" & LrA2))
Count = 0
'Contar número Totales de líneas en rojo
On Error Resume Next
For Each t In RangoTotales
If t.Font.ColorIndex = 3 And Not IsEmpty(t.Value) Then
Cuenta = Cuenta + 1
End If
Next
On Error GoTo 0
If Cuenta = 0 Then
MsgBox "No se encontraron líneas con texto en rojo para copiar a hoja ""X Año"".", vbInformation, " Información"
Exit Sub
End If
'Llenar el arreglo con todas las líneas con texto en rojo dentro de hoja FacturaN
ReDim Totales(1 To Cuenta)
Cuenta = 1
For Each t In RangoTotales
If t.Font.ColorIndex = 3 And Not IsEmpty(t.Value) Then
r = t.Row: c = t.Column
'Totales(Cuenta) = .Cells(r, c).Text & "|" & .Cells(r, c + 1).Text & "|" & .Cells(r, c + 2).Text & "|" & .Cells(r, c + 3).Text
Totales(Cuenta) = .Cells(r, c).Value & "|" & .Cells(r, c + 1).Value & "|" & .Cells(r, c + 2).Value & "|" & .Cells(r, c + 3).Value
Cuenta = Cuenta + 1
End If
Next
End With
'#2 Llenar arreglo con totales de hoja "X Año"
With Sheets("X Año")
LrA1 = .Range("A65000").End(xlUp).Row: LrA2 = .Range("G65000").End(xlUp).Row
Set RangoTotales = Union(.Range("A2:A" & LrA1), .Range("G2:G" & LrA2))
Cuenta = 0
'Contar número Totales de líneas en rojo
For Each x In RangoTotales
If x.Font.ColorIndex = 3 And Not IsEmpty(x.Value) Then
Cuenta = Cuenta + 1
End If
Next
'Llenar el arreglo con todas las líneas en rojo dentro de hoja FacturaN
ReDim Totales_X_Año(1 To Cuenta)
Cuenta = 1
For Each x In RangoTotales
If x.Font.ColorIndex = 3 And Not IsEmpty(x.Value) Then
r = x.Row: c = x.Column
'Totales_X_Año(Cuenta) = .Cells(r, c).Text & "|" & .Cells(r, c + 1).Text & "|" & .Cells(r, c + 2).Text & "|" & .Cells(r, c + 3).Text
Totales_X_Año(Cuenta) = .Cells(r, c).Value & "|" & .Cells(r, c + 1).Value & "|" & .Cells(r, c + 2).Value & "|" & .Cells(r, c + 3).Value
Cuenta = Cuenta + 1
End If
Next
'For i = 1 To UBound(Totales)
' Sheets("X Año").Cells(i + 9, "C") = Totales(i)
'Next
'For i = 1 To UBound(Totales_X_Año)
' Sheets("X Año").Cells(i + 9, "D") = Totales_X_Año(i)
'Next
'Verificar en qué línea de hoja "X Año" se debe pegar las líneas nuevas al comparar ambos arreglos
For i = 1 To UBound(Totales)
If UBound(Filter(Totales_X_Año, Totales(i), , vbBinaryCompare)) < 0 Then
LrA1 = .Range("A65000").End(xlUp).Row: LrA2 = .Range("G65000").End(xlUp).Row
If LrA1 < 395 Then 'And IsEmpty(.Cells(LrA1 + 1, "A")) Then
'Pegar las líneas nuevas encontradas en la próxima línea vacías en hoja "X Año"
.Cells(LrA1 + 1, "A").Resize(, 4) = Split(Totales(i), "|")
For Each XCelda In .Range("B" & LrA1 + 1 & ":D" & LrA1 + 1)
.Cells(LrA1 + 1, "a").Resize(, 4).Font.ColorIndex = 3 'linea para pegar la linea de texto en COLOR ROJO
XCelda.Value = CDec(XCelda.Value)
If XCelda.Value = 0 Then XCelda.ClearContents
Next
ElseIf LrA2 < 395 Then 'And IsEmpty(.Cells(LrA2 + 1, "G")) Then
'Pegar las líneas nuevas encontradas en la próxima línea vacías en hoja "X Año"
.Cells(LrA2 + 1, "G").Resize(, 4) = Split(Totales(i), "|")
For Each XCelda In .Range("H" & LrA2 + 1 & ":J" & LrA2 + 1)
.Cells(LrA2 + 1, "g").Resize(, 4).Font.ColorIndex = 3 'linea para pegar la linea de texto en COLOR ROJO
XCelda.Value = CDec(XCelda.Value)
If XCelda.Value = 0 Then XCelda.ClearContents
Next
Else
MsgBox "Completó 395 líneas llenas de ""Total..."" en lado izquierdo y 395 en lado derecho de hoja ""X Año"", si quiere introducir más debe modificar el código VBA.", vbInformation, " Información"
End If
End If
Next
End With
Sheets("X Año").Select
End Sub
Este codigo funciona de a millon, MUY BIEN, está perfecto pero;
Quisiera cambiar la linea With Sheets("Factura1") (SOLO ESTA) por otra que me permita tener un boton en cada hoja que funcione con el mismo codigo. Algo de ActiveSheets que me funcione en la hoja activa (visible)
Tengo este codigo que me suministro un amigo de acá de la pagina mrExcel.com pero se encuentra un poco enfermo y no quiero molestarlo (por ahora)
Sub Llenar_Con_Totales()
Dim RangoTotales As Range, Totales(), Totales_X_Año(), t As Range, x As Range
Dim Cuenta As Integer, i As Integer, LrA1 As Integer, LrA2 As Integer
Dim r As Integer, c As Integer, XCelda As Range
'#1 Llenar arreglo con líneas totales (en rojo) de la hoja FacturaN
With Sheets("Factura1")
LrA1 = .Range("B65000").End(xlUp).Row: LrA2 = .Range("I65000").End(xlUp).Row
Set RangoTotales = Union(.Range("B2:B" & LrA1), .Range("I2:I" & LrA2))
Count = 0
'Contar número Totales de líneas en rojo
On Error Resume Next
For Each t In RangoTotales
If t.Font.ColorIndex = 3 And Not IsEmpty(t.Value) Then
Cuenta = Cuenta + 1
End If
Next
On Error GoTo 0
If Cuenta = 0 Then
MsgBox "No se encontraron líneas con texto en rojo para copiar a hoja ""X Año"".", vbInformation, " Información"
Exit Sub
End If
'Llenar el arreglo con todas las líneas con texto en rojo dentro de hoja FacturaN
ReDim Totales(1 To Cuenta)
Cuenta = 1
For Each t In RangoTotales
If t.Font.ColorIndex = 3 And Not IsEmpty(t.Value) Then
r = t.Row: c = t.Column
'Totales(Cuenta) = .Cells(r, c).Text & "|" & .Cells(r, c + 1).Text & "|" & .Cells(r, c + 2).Text & "|" & .Cells(r, c + 3).Text
Totales(Cuenta) = .Cells(r, c).Value & "|" & .Cells(r, c + 1).Value & "|" & .Cells(r, c + 2).Value & "|" & .Cells(r, c + 3).Value
Cuenta = Cuenta + 1
End If
Next
End With
'#2 Llenar arreglo con totales de hoja "X Año"
With Sheets("X Año")
LrA1 = .Range("A65000").End(xlUp).Row: LrA2 = .Range("G65000").End(xlUp).Row
Set RangoTotales = Union(.Range("A2:A" & LrA1), .Range("G2:G" & LrA2))
Cuenta = 0
'Contar número Totales de líneas en rojo
For Each x In RangoTotales
If x.Font.ColorIndex = 3 And Not IsEmpty(x.Value) Then
Cuenta = Cuenta + 1
End If
Next
'Llenar el arreglo con todas las líneas en rojo dentro de hoja FacturaN
ReDim Totales_X_Año(1 To Cuenta)
Cuenta = 1
For Each x In RangoTotales
If x.Font.ColorIndex = 3 And Not IsEmpty(x.Value) Then
r = x.Row: c = x.Column
'Totales_X_Año(Cuenta) = .Cells(r, c).Text & "|" & .Cells(r, c + 1).Text & "|" & .Cells(r, c + 2).Text & "|" & .Cells(r, c + 3).Text
Totales_X_Año(Cuenta) = .Cells(r, c).Value & "|" & .Cells(r, c + 1).Value & "|" & .Cells(r, c + 2).Value & "|" & .Cells(r, c + 3).Value
Cuenta = Cuenta + 1
End If
Next
'For i = 1 To UBound(Totales)
' Sheets("X Año").Cells(i + 9, "C") = Totales(i)
'Next
'For i = 1 To UBound(Totales_X_Año)
' Sheets("X Año").Cells(i + 9, "D") = Totales_X_Año(i)
'Next
'Verificar en qué línea de hoja "X Año" se debe pegar las líneas nuevas al comparar ambos arreglos
For i = 1 To UBound(Totales)
If UBound(Filter(Totales_X_Año, Totales(i), , vbBinaryCompare)) < 0 Then
LrA1 = .Range("A65000").End(xlUp).Row: LrA2 = .Range("G65000").End(xlUp).Row
If LrA1 < 395 Then 'And IsEmpty(.Cells(LrA1 + 1, "A")) Then
'Pegar las líneas nuevas encontradas en la próxima línea vacías en hoja "X Año"
.Cells(LrA1 + 1, "A").Resize(, 4) = Split(Totales(i), "|")
For Each XCelda In .Range("B" & LrA1 + 1 & ":D" & LrA1 + 1)
.Cells(LrA1 + 1, "a").Resize(, 4).Font.ColorIndex = 3 'linea para pegar la linea de texto en COLOR ROJO
XCelda.Value = CDec(XCelda.Value)
If XCelda.Value = 0 Then XCelda.ClearContents
Next
ElseIf LrA2 < 395 Then 'And IsEmpty(.Cells(LrA2 + 1, "G")) Then
'Pegar las líneas nuevas encontradas en la próxima línea vacías en hoja "X Año"
.Cells(LrA2 + 1, "G").Resize(, 4) = Split(Totales(i), "|")
For Each XCelda In .Range("H" & LrA2 + 1 & ":J" & LrA2 + 1)
.Cells(LrA2 + 1, "g").Resize(, 4).Font.ColorIndex = 3 'linea para pegar la linea de texto en COLOR ROJO
XCelda.Value = CDec(XCelda.Value)
If XCelda.Value = 0 Then XCelda.ClearContents
Next
Else
MsgBox "Completó 395 líneas llenas de ""Total..."" en lado izquierdo y 395 en lado derecho de hoja ""X Año"", si quiere introducir más debe modificar el código VBA.", vbInformation, " Información"
End If
End If
Next
End With
Sheets("X Año").Select
End Sub
Este codigo funciona de a millon, MUY BIEN, está perfecto pero;
Quisiera cambiar la linea With Sheets("Factura1") (SOLO ESTA) por otra que me permita tener un boton en cada hoja que funcione con el mismo codigo. Algo de ActiveSheets que me funcione en la hoja activa (visible)
