Deux valeurs de lignes similaires pour deux horaires différents

Le 31/01/2022 à 21:55

Bonjour à tous,

Je me suis largement inspiré d'une réponse de Ric pour créer mon code et d'abord merci à lui!

Désormais je suis coincée, dans l'onglet "table de base", je cherche à compléter les colonnes B et C pour compléter un graphique qui représente 24h.

C'est super! Mais entre ma recherche de 12h et 14h, (rechP3 et rechP4) le process est confus puisque la ligne de P3 et P4 retourne la même valeur.

ça me hérisse les neurones.

Si quelqu'un trouve mon erreur, ou me donne une méthode plus simple je serais ravie ;)

7evaluation-realisation-temperature-4-copie.xlsm (200.84 Ko)
Le 01/02/2022 à 06:54

Bonjour,

Dans la colonne A des horaires, la recherche doit intégrer le jour à ces horaires. "Jour + Heure" déclaré en variable double et non en date.

la recherche doit se faire sur la valeur réelle et non partielle "Xlwhole" à la place de "Xlpart".

Le code du module "Temps24h"

Public Jour As Long 'Déclaration de la variable publique

Sub Chauffage()
    Set fe = Worksheets("Table de base") 'Feuille de recherche
    Jour = Int(fe.Range("A9").Value)
    debTempJ = CDbl(Jour + fe.Range("B4").Value)      'horaire de début de chaque période
    dEbPic = CDbl(Jour + fe.Range("C4").Value)
    OPic = CDbl(Jour + fe.Range("D4").Value)
    FinPic = CDbl(Jour + fe.Range("E4").Value)
    ReTempJ = CDbl(Jour + fe.Range("F4").Value)
    FinTempJ = CDbl(Jour + fe.Range("G4").Value)
    debTempN = CDbl(Jour + fe.Range("H4").Value)
    FinTempN = CDbl(Jour + fe.Range("I4").Value)
    FinTab = CDbl(Jour + fe.Range("B1448").Value)
    fe.Range("B4").Value = Sheets("Eph2022").Range("F2").Value
    fe.Range("H4").Value = Sheets("Eph2022").Range("G2").Value
    fe.Range("B9:I1448").ClearContents

    'MsgBox "La cellule B4 ne contient pas une date. Recherche impossible."

    'fillP1 avec Temp de jour
    Set RchP1 = fe.Range("A9:A1448").Find(What:=debTempJ, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not RchP1 Is Nothing Then
        LI1 = RchP1.Row
        fe.Cells(LI1, 2).Value = Range("B2").Value
    End If

    'rechercher P2=fin de P1
    Set RchP2 = fe.Range("A9:A1448").Find(What:=dEbPic, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not RchP2 Is Nothing Then
        LI2 = RchP2.Row
        fe.Cells(LI2, 2).Value = Range("C2").Value
    End If

    '.....REMPLIR LES CASES P1 A P2
    val = LI2 - LI1
    a = ((Range("C2").Value - Range("B2").Value)) / val
    i = 1
    Do While LI1 + i < LI2
        Cells(LI1 + i, 2) = Range("B2").Value + a * i
        i = i + 1
    Loop

    'rechercher P3=début de Temp Pic
    Set RchP3 = fe.Range("A9:A1448").Find(What:=OPic, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not RchP3 Is Nothing Then
        LI3 = RchP3.Row
        fe.Cells(LI3, 2).Value = Range("D2").Value
    End If

    '.....REMPLIR LES CASES P2 A P3
    val1 = LI3 - LI2
    a1 = ((Range("D2").Value - Range("C2").Value)) / val1
    i = 1
    Do While LI2 + i < LI3
        Cells(LI2 + i, 2) = Range("C2").Value + a1 * i
        i = i + 1
    Loop

    'rechercher P4=FIN de Temp Pic
    Set RchP4 = fe.Range("A9:A1448").Find(What:=FinPic, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not RchP4 Is Nothing Then
        LI4 = RchP4.Row
        fe.Cells(LI4, 2).Value = Range("E2").Value
    End If

    '.....REMPLIR LES CASES P3 A P4
    val2 = LI4 - LI3
    a2 = ((Range("E2").Value - Range("D2").Value)) / val2
    i = 1
    Do While LI3 + i < LI4
        Cells(LI3 + i, 2) = Range("D2").Value + a2 * i
        i = i + 1
    Loop

    'rechercher P5=retour de Temp Jour
    Set RchP5 = fe.Columns(1).Find(What:=ReTempJ, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not RchP5 Is Nothing Then
        LI5 = RchP5.Row
        fe.Cells(LI5, 2).Value = Range("F2").Value
    End If

    '.....REMPLIR LES CASES P4 A P5
    val3 = LI5 - LI4
    a3 = ((Range("F2").Value - Range("E2").Value)) / val3
    i = 1
    Do While LI4 + i < LI5
        Cells(LI4 + i, 2) = Range("E2").Value + a3 * i
        i = i + 1
    Loop

    'rechercher P6=fin de Temp Jour
    Set RchP6 = fe.Columns(1).Find(What:=FinTempJ, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not RchP6 Is Nothing Then
        LI6 = RchP6.Row
        fe.Cells(LI6, 2).Value = Range("G2").Value
    End If

    '.....REMPLIR LES CASES P5 A P6
    val4 = LI6 - LI5
    a4 = ((Range("G2").Value - Range("F2").Value)) / val4
    i = 1
    Do While LI5 + i < LI6
        Cells(LI5 + i, 2) = Range("F2").Value + a4 * i
        i = i + 1
    Loop

    'rechercher P7=début de temp Nuit
    Set RchP7 = fe.Columns(1).Find(What:=debTempN, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not RchP7 Is Nothing Then
        LI7 = RchP7.Row
        fe.Cells(LI7, 2).Value = Range("H2").Value
    End If

    '.....REMPLIR LES CASES P6 A P7
    val5 = LI7 - LI6
    a5 = ((Range("H2").Value - Range("G2").Value)) / val5
    i = 1
    Do While LI6 + i < LI7
        Cells(LI6 + i, 2) = Range("G2").Value + a5 * i
        i = i + 1
    Loop

    'rechercher P8=fin de temp Nuit
    Set RchP8 = fe.Columns(1).Find(What:=FinTempN, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not RchP8 Is Nothing Then
        LI8 = RchP8.Row
        fe.Cells(LI8, 2).Value = Range("I2").Value
    End If

    '.....REMPLIR LES CASES P7 à FinTab
    val6 = 1448 - LI7 + LI8 - 8
    a6 = ((Range("I2").Value - Range("H2").Value)) / val6
    i = 1
    Do While LI7 + i < 1449
        Cells(LI7 + i, 2) = Range("H2").Value + a6 * i
        i = i + 1
    Loop
    Range("B9") = Range("B1448") + a6

    '.....REMPLIR LES CASES Minuit à P8
    i = 1
    Do While 8 + i < LI8
        Cells(8 + i, 2) = Range("B9").Value + a6 * i
        i = i + 1
    Loop

    ' remplir fin nuit vers T°jour
    val7 = LI8 - LI1
    a7 = ((Range("I2").Value - Range("B2").Value)) / val7
    i = 1
    Do While LI8 + i < LI1
        Cells(LI8 + i, 2) = Range("I2").Value + a7 * i
        i = i + 1
    Loop

    'entrer la valeur P7=Temp nuit du début de Temp nuit à 00:00
    'fe.Range(Cells(LI7, 2), Cells(1448, 2)).FillDown
    'entrer la valeur P7=Temp nuit pour chaque min entre 00:00 et la relance
    'fe.Range(Cells(6, 2), Cells(LI8, 2)).FillUp

    'Calcul de la T°moyenne de jour prévue LS/CS (P1 àP7)
    Range("J2").Value = Application.WorksheetFunction. _
    Average(fe.Range(Cells(LI1, 2), Cells(LI7 - 1, 2)))

    'Calcul de la T°moyenne de nuit prévue CS/LS (P7 à fin de valeur et de début de valeur à P1 )
    Range("K2").Value = Application.WorksheetFunction. _
    Average(fe.Range(Cells(LI7, 2), Cells(1448, 2)), fe.Range(Cells(9, 2), Cells(LI1 - 1, 2)))

    'Calcul de la T°moyenne 24h prévue LS/LS (P1 à P1 J+1 )
    Range("L2").Value = Application.WorksheetFunction. _
    Average(fe.Range("B9:B1448"))
End Sub

Le code du module "Temps24hAération"

Sub Aeration()
    Set fe = Worksheets("Table de base")    'Feuille de recherche
    adebTempJ = CDbl(Jour + fe.Range("B7").Value)         'horaire de début de chaque période
    adEbPic = CDbl(Jour + fe.Range("C7").Value)
    aOPic = CDbl(Jour + fe.Range("D7").Value)
    aFinPic = CDbl(Jour + fe.Range("E7").Value)
    aReTempJ = CDbl(Jour + fe.Range("F7").Value)
    aFinTempJ = CDbl(Jour + fe.Range("G7").Value)
    adebTempN = CDbl(Jour + fe.Range("H7").Value)
    aFinTempN = CDbl(Jour + fe.Range("I7").Value)
    aFinTab = fe.Range("B1448").Value
    'fe.Range("B4").Value = Sheets("Eph2022").Range("F2").Value
    'fe.Range("H4").Value = Sheets("Eph2022").Range("G2").Value
    'fe.Range("B9:I1448").ClearContents

    'fill aP1 avec Temp de jour
    Set aRchP1 = fe.Columns(1).Find(What:=adebTempJ, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not aRchP1 Is Nothing Then
        aLI1 = aRchP1.Row
        fe.Cells(aLI1, 4).Value = Range("B5").Value
    End If

    'rechercher P2=fin de P1
    Set aRchP2 = fe.Columns(1).Find(What:=adEbPic, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not aRchP2 Is Nothing Then
        aLI2 = aRchP2.Row
        fe.Cells(aLI2, 4).Value = Range("C5").Value
    End If

    '.....REMPLIR LES CASES P1 A P2
    aval = aLI2 - aLI1
    aa = ((Range("C5").Value - Range("B5").Value)) / aval
    i = 1
    Do While aLI1 + i < aLI2
        Cells(aLI1 + i, 4) = Range("B5").Value + aa * i
        i = i + 1
    Loop

    'rechercher P3=début de Temp Pic
    Set aRchP3 = fe.Columns(1).Find(What:=aOPic, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not aRchP3 Is Nothing Then
        aLI3 = aRchP3.Row
        fe.Cells(aLI3, 4).Value = Range("D5").Value
    End If

    '.....REMPLIR LES CASES P2 A P3
    aval1 = aLI3 - aLI2
    aa1 = ((Range("D5").Value - Range("C5").Value)) / aval1
    i = 1
    Do While aLI2 + i < aLI3
        Cells(aLI2 + i, 4) = Range("C5").Value + aa1 * i
        i = i + 1
    Loop

    'rechercher P4=FIN de Temp Pic
    Set aRchP4 = fe.Columns(1).Find(What:=aFinPic, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not aRchP4 Is Nothing Then
        aLI4 = aRchP4.Row
        fe.Cells(aLI4, 4).Value = Range("E5").Value
    End If

    '.....REMPLIR LES CASES P3 A P4
    aval2 = aLI4 - aLI3
    aa2 = ((Range("E5").Value - Range("D5").Value)) / aval2
    i = 1
    Do While aLI3 + i < aLI4
        Cells(aLI3 + i, 4) = Range("D5").Value + aa2 * i
        i = i + 1
    Loop

    'rechercher P5=retour de Temp Jour
    Set aRchP5 = fe.Columns(1).Find(What:=aReTempJ, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not aRchP5 Is Nothing Then
        aLI5 = aRchP5.Row
        fe.Cells(aLI5, 4).Value = Range("F5").Value
    End If

    '.....REMPLIR LES CASES P4 A P5
    aval3 = aLI5 - aLI4
    aa3 = ((Range("F5").Value - Range("E5").Value)) / (aval3 + 0.5)
    i = 1
    Do While aLI4 + i < aLI5
        Cells(aLI4 + i, 4) = Range("E5").Value + aa3 * i
        i = i + 1
    Loop

    'rechercher P6=fin de Temp Jour
    Set aRchP6 = fe.Columns(1).Find(What:=aFinTempJ, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not aRchP6 Is Nothing Then
        aLI6 = aRchP6.Row
        fe.Cells(aLI6, 4).Value = Range("G5").Value
    End If

    '.....REMPLIR LES CASES P5 A P6
    aval4 = aLI6 - aLI5
    aa4 = ((Range("G5").Value - Range("F5").Value)) / aval4
    i = 1
    Do While aLI5 + i < aLI6
        Cells(aLI5 + i, 4) = Range("F5").Value + aa4 * i
        i = i + 1
    Loop

    'rechercher P7=début de temp Nuit
    Set aRchP7 = fe.Columns(1).Find(What:=adebTempN, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not aRchP7 Is Nothing Then
        aLI7 = aRchP7.Row
        fe.Cells(aLI7, 4).Value = Range("H5").Value
    End If

    '.....REMPLIR LES CASES P6 A P7
    aval5 = aLI7 - aLI6
    aa5 = ((Range("H5").Value - Range("G5").Value)) / aval5
    i = 1
    Do While aLI6 + i < aLI7
        Cells(aLI6 + i, 4) = Range("G5").Value + aa5 * i
        i = i + 1
    Loop

    'rechercher P8=fin de temp Nuit
    Set aRchP8 = fe.Columns(1).Find(What:=aFinTempN, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)
    If Not aRchP8 Is Nothing Then
        aLI8 = aRchP8.Row
        fe.Cells(aLI8, 4).Value = Range("I5").Value
    End If

    '.....REMPLIR LES CASES P7 à FinTab
    aval6 = 1448 - aLI7 + aLI8 - 8
    aa6 = ((Range("I5").Value - Range("H5").Value)) / aval6
    i = 1
    Do While aLI7 + i < 1449
        Cells(aLI7 + i, 4) = Range("H5").Value + aa6 * i
        i = i + 1
    Loop
    Range("D9") = Range("D1448") + aa6

    '.....REMPLIR LES CASES Minuit à P8
    i = 1
    Do While 8 + i < aLI8
        Cells(8 + i, 4) = Range("D9").Value + aa6 * i
        i = i + 1
    Loop

    ' remplir fin nuit vers T°jour
    aval7 = aLI8 - aLI1
    aa7 = ((Range("I5").Value - Range("B5").Value)) / aval7
    i = 1
    Do While aLI8 + i < aLI1
        Cells(aLI8 + i, 4) = Range("I5").Value + aa7 * i
        i = i + 1
    Loop

    'entrer la valeur P7=Temp nuit du début de Temp nuit à 00:00
    'fe.Range(Cells(LI7, 2), Cells(1448, 2)).FillDown
    'entrer la valeur P7=Temp nuit pour chaque min entre 00:00 et la relance
    'fe.Range(Cells(6, 2), Cells(LI8, 2)).FillUp

    'Calcul de la T°moyenne de jour prévue LS/CS (P1 àP7)
    Range("J5").Value = Application.WorksheetFunction. _
    Average(fe.Range(Cells(aLI1, 4), Cells(aLI7 - 1, 4)))

    'Calcul de la T°moyenne de nuit prévue CS/LS (P7 à fin de valeur et de début de valeur à P1 )
    Range("K5").Value = Application.WorksheetFunction. _
    Average(fe.Range(Cells(aLI7, 4), Cells(1448, 4)), fe.Range(Cells(9, 4), Cells(aLI1 - 1, 4)))

    'Calcul de la T°moyenne 24h prévue LS/LS (P1 à P1 J+1 )
    Range("L5").Value = Application.WorksheetFunction. _
    Average(fe.Range("D9:D1448"))
End Sub

le fichier

8ired-deux-valeurs-de-lignes-similaires-pour-deux-horaires-differents.xlsb (146.49 Ko)

Cdlt

Le 01/02/2022 à 09:55

WAOUH ! c'est phénoménal ça, merci t'es super. c'est magique de se réveiller avec la solution clé en main!

J'avais bien tenté des approche de ce genre mais j'aurais jamais deviné seule.

De plus si la date est prise en compte je vais pouvoir boucler sur la semaine, ça ouvre de nouvelles perspectives!

Encore merci pour le coup de pouce, bonne continuation.

Rechercher des sujets similaires à "deux valeurs lignes similaires horaires differents"