colorear la fila de los totales

Joselica

New Member
Joined
Apr 3, 2016
Messages
18
Office Version
  1. 2007
Hola,
He adaptado una macro sin entender mucho sobre ella y el VBA.
En la hoja "LISTADO" introduzco una fecha en la celda "K7" y me devuelve un listado con los totales.
Tambien no se como arreglar el tema de la celda "K7" en cuanto no hay nada en la celda (me da un debug, adjunto pantallazo:
Me encuentro con el problema de no saber como puedo colorear en gris la fila de los totales y poner las letras en negrita.
Adjunto la macro en causa:
VBA Code:
Sub nueva(target As Range)
Dim uF&, cel As Range
Dim t1, t2, t3
Dim h1&, h2&, h3&, rrw&, rrw1&, rrw2&, rrw3&

Application.ScreenUpdating = False

ActiveSheet.Unprotect Password:="1234"

rrw1 = Hoja1.Cells(Rows.Count, 13).End(xlUp).Row
rrw2 = Hoja1.Cells(Rows.Count, 16).End(xlUp).Row
rrw3 = Hoja1.Cells(Rows.Count, 19).End(xlUp).Row

rrw = WorksheetFunction.Max(rrw1, rrw2, rrw3)

Range("K10:S" & rrw + 1).ClearContents

uF = Range("B" & Rows.Count).End(xlUp).Row

ReDim t1(1 To uF, 1 To 3): ReDim t2(1 To uF, 1 To 3): ReDim t3(1 To uF, 1 To 3)
h1 = 1: h2 = 1: h3 = 1

For Each cel In Range("B7:B" & uF)
    If cel.Offset(, 4) = target Then
        Select Case cel.Offset(, 5)
            Case "T1"
                t1(h1, 1) = cel
                t1(h1, 2) = cel.Offset(, 1)
                t1(h1, 3) = cel.Offset(, 6)
                h1 = h1 + 1
            Case "T2"
                t2(h2, 1) = cel
                t2(h2, 2) = cel.Offset(, 1)
                t2(h2, 3) = cel.Offset(, 6)
                h2 = h2 + 1
            Case "T3"
                t3(h3, 1) = cel
                t3(h3, 2) = cel.Offset(, 1)
                t3(h3, 3) = cel.Offset(, 6)
                h3 = h3 + 1
        End Select
    End If
Next cel
'Devuelve los datos HAB/NOMBRE y PAX
Cells(10, "K").Resize(h1, 3) = t1
Cells(10, "N").Resize(h2, 3) = t2
Cells(10, "Q").Resize(h3, 3) = t3
'Desplaza las filas hasta la ultima fila con datos
rrw1 = Hoja1.Cells(Rows.Count, 13).End(xlUp).Row
rrw2 = Hoja1.Cells(Rows.Count, 16).End(xlUp).Row
rrw3 = Hoja1.Cells(Rows.Count, 19).End(xlUp).Row
rrw = WorksheetFunction.Max(rrw1, rrw2, rrw3)

ActiveWorkbook.Worksheets("LISTADO").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("LISTADO").Sort.SortFields.Add Key:=Range("K10"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("LISTADO").Sort
    .SetRange Range("K10:M" & rrw1) 'SetRange Range("K6:M100")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

ActiveWorkbook.Worksheets("LISTADO").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("LISTADO").Sort.SortFields.Add Key:=Range("N10"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("LISTADO").Sort
    .SetRange Range("N10:P" & rrw2)
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

ActiveWorkbook.Worksheets("LISTADO").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("LISTADO").Sort.SortFields.Add Key:=Range("Q10"), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("LISTADO").Sort
    .SetRange Range("Q10:S" & rrw3)
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Cells(rrw + 1, "K") = "Total:": Cells(rrw + 1, "N") = "Total:": Cells(rrw + 1, "Q") = "Total:"
'Suma y devuelve los totales de los PAX hasta ultima fila con datos
Cells(rrw + 1, "M") = WorksheetFunction.Sum(Range("M10:M" & rrw))
Cells(rrw + 1, "P") = WorksheetFunction.Sum(Range("P10:P" & rrw))
Cells(rrw + 1, "S") = WorksheetFunction.Sum(Range("S10:S" & rrw))

ActiveSheet.Protect Password:="1234"

End Sub
Hay alguna posibilidad de subir el documento?
Gracias por vuestra ayuda.
Saludos,
 

Attachments

  • 1605106275889.png
    1605106275889.png
    176.4 KB · Views: 5

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

Forum statistics

Threads
1,213,497
Messages
6,113,999
Members
448,541
Latest member
iparraguirre89

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top