Macro búsqueda datos en lista con intervalos variables

Por macro el resultado seria el siguiente:

Y este es el código que ocupas, va a poner una serie de números que son necesarios para establecer los rangos, calcular los máximos y mínimos así como realizar la copia, al final los borra, pruébalas y comentas

Option Base 1
Sub EJECUTA()
RECABAR_DATOS
MAXMINI
End Sub
 Sub RECABAR_DATOS()
 Set datos = Range("A1").CurrentRegion
 With datos
    FILAS = .Rows.Count
    Set datos = .Resize(.Rows.Count, 3)
    X = 1
    For I = 1 To FILAS
        NUMERO = .Cells(I, 2): NUMERO2 = .Cells(I + 1, 2)
        If NUMERO > 0 And NUMERO2 < 0 Or NUMERO < 0 And NUMERO2 > 0 Then
            .Cells(I, 3) = X
        End If
        X = X + 1
    Next I
    CONTAR = WorksheetFunction.CountA(.Columns(3))
    Set RESULTADO = Range("D1").Resize(CONTAR, 2)
    RESULTADO.Name = "RESULTADO"
    Set NUMEROS = Range("G1").Resize(CONTAR, 1)
    MATRIZ = NUMEROS
    Y = 1
    For J = 1 To FILAS
        NUMERO = .Cells(J, 3)
        If NUMERO <> Empty Then
            MATRIZ(Y, 1) = NUMERO
            Y = Y + 1
        End If
    Next J
    With NUMEROS
        Range(.Address) = MATRIZ
        .Name = "NUMEROS"
    End With
    .Name = "DATOS"
 End With
 Set datos = Nothing: Set NUMEROS = NUMEROS
 Set MATRIZ = Nothing
 End Sub
 Sub MAXMINI()
 Set NUMEROS = Range("NUMEROS")
 Set datos = Range("DATOS")
 Set RESULTADO = Range("RESULTADO")
 With NUMEROS
    FILAS = .Rows.Count
    For I = 1 To FILAS
        If I = 1 Then
            NUMERO = .Cells(I, 1)
            Set area = datos.Resize(NUMERO)
        End If
        If I > 1 Then
            NUMERO = .Cells(I, 1) - .Cells(I - 1, 1)
            Set area = area.Rows(area.Rows.Count + 1).Resize(NUMERO)
        End If
OTRO:
        CUENTAMM = WorksheetFunction.CountIf(area.Columns(2), "<0")
        CUENTAmY = WorksheetFunction.CountIf(area.Columns(2), ">0")
        If CUENTAmY > 0 Then
            maxi = WorksheetFunction.Max(area.Columns(2))
            valor = maxi
        Else
            mini = WorksheetFunction.Min(area.Columns(2))
            valor = mini
        End If
        fila = WorksheetFunction.Match(valor, area.Columns(2), 0)
        If sal = "NO" Then
            RESULTADO.Rows(RESULTADO.Rows.Count + 1).Value = area.Rows(fila).Value
            GoTo SALIR
        Else
            RESULTADO.Rows(I).Value = area.Rows(fila).Value
        End If
    Next I
 End With
 DFILAS = datos.Rows.Count - NUMEROS.Cells(NUMEROS.Rows.Count, 1)
 Set area = datos.Rows(datos.Rows.Count - DFILAS + 1).Resize(DFILAS, 2)
 sal = "NO"
 If sal = "NO" Then GoTo OTRO
SALIR:
Range("numeros"). Clear
Datos. Columns(3). Clear
 End Sub

Buena noche.

Estoy infinitamente agradecido, era lo que necesitaba. Pero tengo un problema, al copiar el código en el editor VBA no corre la macro. Creo que estoy haciendo algo mal o me falta colocar algún comando adicional, gracias de nuevo por tu valiosa colaboración.

Se me paso decirte que son tres macros separadas, la macro con el nombre ejecuta las va activando consecutivamente y fueron programadas sobre la información que pusiste en el archivo excel, si lo usas en un archivo diferente o las columnas con información están en otras celdas las macros no funcionaran a menos que cambies la línea set datos=range("a1"). Currentregion de la macro recabar datos por la referencia donde están tus datos.

En caso de no seguir funcionado vuelve a poner aquí el archivo con la macro incluida como lo hiciste en el primer post para ver que esta pasando.

Muchas gracias por tu interés en ayudarme, ya logré que funcionara una parte pero me sale un error al final, envío la hoja de excel con las 3 macros montadas pero me parece que una ellas la estoy definiendo mal. Gracias por tu atención.

archivo con macros