Résumer suite à période

Question

Je reviens vers vous pour avoir un petit coup de pouce, svp. Car vue mes compétences en vba, je me sent dépassé. Je suis en cour de construction d'un classeur hyper important pour mon travail, qui est déjà pas mal avancé grâce à l'aide de Galopin01 qui ma bien aidé. Pour ma demande j'ai joins un classeur simplifier et vais donc essayer de vous expliquer au mieux nos attentes. Pour résumer, nos attentes au niveau de mon service est d'observer les animaux sur notre site et évidemment de tout notifier afin d'effectuer des statistiques de risque en fin d'année. Ce fichier aura pour fonction d'enregistrer sur la feuille "ArchMissionBas" qui sert de BDD toutes les observations effectuées jour après jour. Nous aimerions, dans la feuille "NbSem" effectuer une recherche avec une date début et date fin, pour plus de souplesse dans le but de récupérer les Noms des individus (col B) Total individus (col C) Nombre de fois vue (col D) Moyenne de fois vue (col E), correspond à (col C) divisé par (col D) Nombre de semaine vue (col F) Si possible sur la même feuille (ou en créer une) récupérer N° de semaine (col I) Date (col J) Nom individus (col K) Efficacité (col L), (col M), correspond à la (col S) de la feuille "ArchMissionBas". Toutes ces données vont servir par la suite à renseigner (des fiches) les feuilles "RisqueOiseau" et "RisqueMamifère" automatiquement on l'espère, si cela est possible ? Je joind le fichier. Si besoin de renseignements complémentaire, n'hésite pas car je sais que ce n'est pas évident à comprendre, et expliquer pour moi. Cordialement...

Klin89 · Accepted Answer

Re pompaero

Le code réajusté :

Efface bien la ligne 4 dans la feuille "NbSem"

Option Explicit
Sub test()
Dim a, b(), w(), i As Long, n As Long, e
Dim debut As Date, fin As Date, dico As Object
    Set dico = CreateObject("Scripting.Dictionary")
    dico.Comparemode = 1
    a = Sheets("ArchMissionBas").[a1].CurrentRegion.Value: n = 1
    debut = [NbSem!c3].Value: fin = [NbSem!e3].Value
    ReDim b(1 To UBound(a, 1), 1 To 5)
    b(n, 1) = "NOM INDIVIDUS": b(n, 2) = "TOTAL individus"
    b(n, 3) = "Nombre de fois vue": b(n, 4) = "MOYENNE de fois vue"
    b(n, 5) = "Nombre de semaine vue"
    For i = 3 To UBound(a, 1)
        If (a(i, 1) >= debut) * (a(i, 1) <= fin) Then
            If Not dico.exists(a(i, 7)) Then
                ReDim w(1 To 2)
                Set w(1) = CreateObject("Scripting.Dictionary")
                n = n + 1: w(2) = n
                b(w(2), 1) = a(i, 7)
                dico(a(i, 7)) = w
            End If
            w = dico(a(i, 7))
            w(1)(SEM(a(i, 1))) = Empty
            b(w(2), 2) = b(w(2), 2) + a(i, 8)
            b(w(2), 3) = b(w(2), 3) + 1
            dico(a(i, 7)) = w
        End If
    Next
    If n > 1 Then
        For Each e In dico.keys
            b(dico(e)(2), 4) = b(dico(e)(2), 2) / b(dico(e)(2), 3)
            b(dico(e)(2), 5) = dico(e)(1).Count
        Next
    End If
    Application.ScreenUpdating = False
    With Sheets("NbSem").Range("B5")
        .CurrentRegion.Clear
        With .Resize(n, UBound(b, 2))
            .Value = b
            .Font.Name = "calibri"
            .BorderAround Weight:=xlThin
            .Borders(xlInsideVertical).Weight = xlThin
            .VerticalAlignment = xlCenter
            With .Rows(1)
                .Font.Size = 11
                .BorderAround Weight:=xlThin
                .HorizontalAlignment = xlCenter
                .Interior.ColorIndex = 37
            End With
            .Columns.AutoFit
        End With
    End With
    If n = 1 Then MsgBox "aucune donnée correspondant à votre requête"
    Set dico = Nothing
    Application.ScreenUpdating = True
End Sub

Function SEM(ByVal d As Date) As String 'Roger2327
    Dim ns&
    d = Int(d)
    ns = DateSerial(Year(d + (8 - Weekday(d, vbSunday)) Mod 7 - 3), 1, 1)
    ns = ((d - ns - 3 + (Weekday(ns, vbSunday) + 1) Mod 7)) \ 7 + 1
    SEM = Year(d) - (ns > 50) * (Month(d) = 1) + (ns < 5) * (Month(d) = 12) & "-W" & Right$("0" & ns, 2)
End Function

klin89

Klin89 · Answer

Pour répondre à la première question : Concernant la restitution en 5ème colonne soit le Nombre de semaine vue , je n'ai pas vraiment pigé. A tester : Option Explicit Sub test() Dim a, b(), w(), i As Long, n As Long, e Dim debut As Date, fin As Date, dico As Object Set dico = CreateObject("Scripting.Dictionary") dico.Comparemode = 1 a = Sheets("ArchMissionBas").&#91;a1&#93;.CurrentRegion.Value: n = 1 debut = &#91;NbSem!c3&#93;.Value: fin = &#91;NbSem!e3&#93;.Value ReDim b(1 To UBound(a, 1), 1 To 5) b(n, 1) = "NOM INDIVIDUS": b(n, 2) = "TOTAL individus" b(n, 3) = "Nombre de fois vue": b(n, 4) = "MOYENNE de fois vue" b(n, 5) = "Nombre de semaine vue" For i = 3 To UBound(a, 1) If (a(i, 1) &gt;= debut) * (a(i, 1) &lt;= fin) Then If Not dico.exists(a(i, 7)) Then ReDim w(1 To 2) Set w(1) = CreateObject("Scripting.Dictionary") n = n + 1: w(2) = n b(w(2), 1) = a(i, 7) dico(a(i, 7)) = w End If w = dico(a(i, 7)) 'clé semaine à modifier ici w(1)(a(i, 1)) = Empty b(w(2), 2) = b(w(2), 2) + a(i, 8) b(w(2), 3) = b(w(2), 3) + 1 dico(a(i, 7)) = w End If Next If n &gt; 1 Then For Each e In dico.keys b(dico(e)(2), 4) = b(dico(e)(2), 2) / b(dico(e)(2), 3) b(dico(e)(2), 5) = dico(e)(1).Count Next End If Application.ScreenUpdating = False On Error Resume Next Application.DisplayAlerts = False Sheets("Restitution").Delete Sheets.Add().Name = "Restitution" On Error GoTo 0 With Sheets("Restitution").Cells(1) With .Resize(n, UBound(b, 2)) .Value = b .Font.Name = "calibri" .BorderAround Weight:=xlThin .Borders(xlInsideVertical).Weight = xlThin .VerticalAlignment = xlCenter With .Rows(1) .Font.Size = 11 .BorderAround Weight:=xlThin .HorizontalAlignment = xlCenter .Interior.ColorIndex = 37 End With .Columns.AutoFit End With End With If n = 1 Then MsgBox "aucune donnée correspondant à votre requête" Set dico = Nothing Application.ScreenUpdating = True End Sub Edit : pour déterminer le N° de semaine , faire une recherche sur le net klin89...