colorear la fila de los totales

[Joselica]

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:

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,

 

[Joselica]

Buenas,
Este es un intento de subir el archivo.

Dropbox

www.dropbox.com

Saludos,