Ayuda para obtener promedios en fila de Totales

[pedrosilv]

Buena noche foristas.

Es un gusto saludarles y solicitarles su apoyo en lo siguiente.

Hace un tiempo obtuve el apoyo de @JSDJSD para una macro que agrega una fila de totales y subtotales en la hoja CUADRO. En esta hoja se importa información de la hojas DATOS. En la actualidad me funciona bien,  en la hoja CUADRO cuenta con 2 columnas denominadas DAP y VOLUMEN. Al final se suman los totales, pero mi deseo es que en la fila Total aparezca la Suma de VOLUMEN (que lo hace muy bien), pero en la columna DAP, obtenga el PROMEDIO de las filas SUBTOTALES, que es lo que aún no logro modificar.

Si pudieran apoyarme, se los agradecería.

La macro es esta:

Sub EXTRAER()
    With Hoja2
        For x = .Range("D" & Rows.Count).End(xlUp).Row To 5 Step -1
            If .Cells(x, 4) = "SUBTOTAL" Or .Cells(x, 4) = "TOTAL" Then
                .Range("D" & x).EntireRow.Delete
            End If
        Next x
        
        
        Hoja1.Range("A1", "E" & Hoja1.Range("E" & Rows.Count).End(xlUp).Row).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=.Range("C4:D4"), Unique:=True
        .Sort.SortFields.Clear
        
        .Range("c4", "d" & .Range("D" & Rows.Count).End(xlUp).Row).Sort Key1:=.Range("C4"), _
        Key2:=.Range("D4"), Header:=xlYes, Order1:=xlAscending, Order2:=xlAscending
        
        .Range("C5:C" & .Range("C" & Rows.Count).End(xlUp).Row).AdvancedFilter 2, , .Range("O5"), 1
        .Range("O:O").Sort Key1:=.Columns("O"), Order1:=xlAscending, Header:=xlYes
        linea = 5
        
        For cont = 3 To .Range("O" & Rows.Count).End(xlUp).Row
            buscado1 = .Cells(cont, 15)
            For Each buscado In .Range("C" & linea, "C" & .Range("C" & Rows.Count).End(xlUp).Row + 1)
                If buscado = buscado1 Then
                
            Else
                .Rows(buscado.Row).Insert
                .Cells(buscado.Row - 1, 4) = "SUBTOTAL"
                .Range("D" & buscado.Row - 1).Font.Bold = True
                .Range("E" & buscado.Row - 1).Font.Bold = True
                .Range("F" & buscado.Row - 1).Font.Bold = True
                .Cells(buscado.Row - 1, 6) = Application.WorksheetFunction.Sum(.Range("F" & linea, "F" & buscado.Row - 1))
                .Cells(buscado.Row - 1, 5) = Round(Application.WorksheetFunction.Average(.Range("E" & linea, "E" & buscado.Row - 1)), 2)
                acumulado = acumulado + CDbl(.Cells(buscado.Row - 1, 6))
                acumulado1 = acumulado1 + CDbl(.Cells(buscado.Row - 1, 5))
                linea = buscado.Row
                Exit For
                End If
            Next
        Next cont
        .Range("D" & linea) = "TOTAL"
        .Range("D" & linea).Font.Bold = True
        .Range("E" & linea) = acumulado1
        .Range("E" & linea).Font.Bold = True
        .Range("F" & linea) = acumulado
        .Range("F" & linea).Font.Bold = True
        .Range("O:O").Columns.Delete
    End With
End Sub

Adjunto el archivo de ejemplo.

EJEMPLO FILTRO.xlsm

[JSDJSD]

 

Sub EXTRAER()
    With Hoja2
        For x = .Range("D" & Rows.Count).End(xlUp).Row To 5 Step -1
            If .Cells(x, 4) = "SUBTOTAL" Or .Cells(x, 4) = "TOTAL" Then
                .Range("D" & x).EntireRow.Delete
            End If
        Next x
        
        
        Hoja1.Range("A1", "E" & Hoja1.Range("E" & Rows.Count).End(xlUp).Row).AdvancedFilter _
        Action:=xlFilterCopy, CopyToRange:=.Range("C4:D4"), Unique:=True
        .Sort.SortFields.Clear
        
        .Range("c4", "d" & .Range("D" & Rows.Count).End(xlUp).Row).Sort Key1:=.Range("C4"), _
        Key2:=.Range("D4"), Header:=xlYes, Order1:=xlAscending, Order2:=xlAscending
        
        .Range("C5:C" & .Range("C" & Rows.Count).End(xlUp).Row).AdvancedFilter 2, , .Range("O5"), 1
        .Range("O:O").Sort Key1:=.Columns("O"), Order1:=xlAscending, Header:=xlYes
        linea = 5
        
        For cont = 3 To .Range("O" & Rows.Count).End(xlUp).Row
            buscado1 = .Cells(cont, 15)
            For Each buscado In .Range("C" & linea, "C" & .Range("C" & Rows.Count).End(xlUp).Row + 1)
                If buscado = buscado1 Then
                
            Else
                .Rows(buscado.Row).Insert
                .Cells(buscado.Row - 1, 4) = "SUBTOTAL"
                .Range("D" & buscado.Row - 1).Font.Bold = True
                .Range("E" & buscado.Row - 1).Font.Bold = True
                .Range("F" & buscado.Row - 1).Font.Bold = True
                .Cells(buscado.Row - 1, 6) = Application.WorksheetFunction.Sum(.Range("F" & linea, "F" & buscado.Row - 1))
                .Cells(buscado.Row - 1, 5) = Round(Application.WorksheetFunction.Average(.Range("E" & linea, "E" & buscado.Row - 1)), 2)
                acumulado = acumulado + CDbl(.Cells(buscado.Row - 1, 6))
                acumulado1 = acumulado1 + CDbl(.Cells(buscado.Row - 1, 5))
                linea = buscado.Row
                Exit For
                End If
            Next
        Next cont
        .Range("D" & linea) = "TOTAL"
        .Range("D" & linea).Font.Bold = True
        .Range("E" & linea) = acumulado1 / (cont - 3)   '<<<<<<<<<< Modifica esta línea en tu macro
        .Range("E" & linea).Font.Bold = True
        .Range("F" & linea) = acumulado
        .Range("F" & linea).Font.Bold = True
        .Range("O:O").Columns.Delete
    End With
End Sub

 

[pedrosilv]

Muchísimas gracias por todo tu apoyo mi estimado @JSDJSD

La macro funciona a la perfección.

Saludos y buena tarde.