Récupération des plusieurs données N-1 vers N1

Le 22/01/2025 à 11:55

Bonjour,

J'ai besoin de votre aide car je ne trouve pas la solution pour coder ce que je veux faire.

J'ai un classeur qui me permet de faire plusieurs actions, mais je bloque sur une partie ou je galère depuis un bon moment.

J'ai des informations qui commencent en B6 (mes entêtes) et finissent en AV et ce tableau fait plus de 30000 lignes et il va encore grandir.

En colonne G j'ai des années et en colonne F des sections.

De P à AV j'ai des chiffres et je veux récupérer les chiffres de P à AV de 2024 et les remettre en face de la bonne section pour l'année 2025.

Par exemple si la section A1 des montants attribués de P à AV, je voudrais que pour l'année 2025 que la section A1 se voit attribuer à nouveau ces montants.

Je vous joins un fichier exemple qui permettra peut-être de mieux comprendre ma demande.

Je pense également qu'il faut prendre en référence B1 qui est l'année en cours, car beaucoup d'année dans cette colonne.

Par exemple :

anC = ws.Range("B1").Value
anP = anC - 1
21test.xlsm (10.14 Ko)

Merci.

Le 22/01/2025 à 22:23

Salut Tespark,

premier jet vite fait à la mi-temps : un double clic en [B1] déclenche la macro si l'année en [B1] et l'année précédente existent dans tes données.
Je trie d'abord les données par année.
J'imagine que dans tes 30.000 lignes et plus, il n'y a qu'une petite partie qui concerne chaque année!?
Si, par année, il y a des milliers de lignes, alors, il faudra refaire la macro autrement, évidemment !!

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim iRow%, iRow1%, iRow2%, iTRow%
'
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("B1")) Is Nothing Then
    Cancel = True
    iRow = Range("B" & Rows.Count).End(xlUp).Row
    Range("B7:AV" & iRow).Sort key1:=Range("G7"), order1:=xlAscending, Orientation:=xlTopToBottom, Header:=xlNo
    On Error Resume Next
    iRow1 = Columns("G").Find(what:=Target - 1, lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
    iRow2 = Columns("G").Find(what:=Target, lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
    If iRow1 > 0 And iRow2 > 0 Then
        For x = iRow1 To iRow2 - 1
            iTRow = 0
            iTRow = Range("F" & x & ":F" & iRow).Find(what:=Cells(x, 6), lookat:=xlWhole, LookIn:=xlValues, searchdirection:=xlNext).Row
            If iTRow > 0 Then _
                Range("P" & iTRow & ":AV" & iTRow).Value = Range("P" & x & ":AV" & x).Value
        Next
    End If
    On Error GoTo 0
End If
'
Application.ScreenUpdating = True
'
End Sub
10tespark.xlsm (16.50 Ko)

A+

Le 22/01/2025 à 23:02

Tespark, salut Curulis,

un autre essai

11tespark.xlsm (22.98 Ko)
Sub test()
     t = Timer
     Set dict = CreateObject("scripting.dictionary")
     With Sheets("Feuil1")
          annee = .Range("B1").Value2
          With Range("F7:G1000")
               arr = .Value2
               For i = 1 To UBound(arr)
                    skey = arr(i, 1) & "|" & arr(i, 2)     'section et annee
                    If Len(skey) > 1 Then
                         skey1 = arr(i, 1) & "|" & arr(i, 2) - 1     'section et annee precedente
                         If arr(i, 2) = annee Then If dict.exists(skey1) Then .Cells(i, 11).Resize(, 33).Value = dict(skey1)
                         dict(skey) = .Cells(i, 11).Resize(, 33).Value2
                    End If
               Next
          End With
     End With
     MsgBox Timer - t
End Sub
Le 23/01/2025 à 09:53

Bonjour Curilus, BsAlv,

Merci pour vos réponses :)

Curilus, effectivement, entre 7 et 8000 lignes par année.

Cela me renvoi un message de dépassement de capacité.

BsAlv, j'ai essayé d'adapter le code mais cela ne fonctionne pas.

Sub test()
    Dim dict As Object
    Dim annee As Integer
    Dim arr As Variant
    Dim i As Long
    Dim skey As String
    Dim skey1 As String
    Dim ws As Worksheet
    Dim rng As Range
    Dim t As Double

    t = Timer
    Set dict = CreateObject("scripting.dictionary")
    Set ws = ThisWorkbook.Sheets("Base_Capex")

    annee = ws.Range("B1").Value2
    Set rng = ws.Range("F7:G1000")

    arr = rng.Value2

    For i = 1 To UBound(arr)
        skey = arr(i, 1) & "|" & arr(i, 2)     'section et annee
        If Len(skey) > 1 Then
            skey1 = arr(i, 1) & "|" & CStr(arr(i, 2) - 1)     'section et annee precedente
            If arr(i, 2) = annee Then
                If dict.exists(skey1) Then
                    rng.Cells(i, 11).Resize(1, 33).Value = dict(skey1)
                End If
            End If
            dict(skey) = rng.Cells(i, 11).Resize(1, 33).Value2
        End If
    Next i

    MsgBox Timer - t
End Sub

Merci

Le 23/01/2025 à 10:06

Salut Tespark,

je n'ai pas mon ordinateur avec moi mais tu peux modifier ainsi.

Dans la première ligne des DIM, change les '%' en '&'.

Dès mon retour, je ferai une macro plus adaptée !

A+

😎

Le 23/01/2025 à 10:07

@tespark,

BsAlv, j'ai essayé d'adapter le code mais cela ne fonctionne pas.

c'est un peu vague, c'est quoi le problème ? Adapter les plages ? Le résultat ?

Autrement mettez un fichier (anonymisé) en PJ avant 8.000 lignes

Le 23/01/2025 à 11:26

Merci pour vos réponses.

Curilus, j'ai fait la manip, mais ça plante.

BsAlv, j'ai modifier pour voir ce qu'il se passe :

Sub test()
    Dim dict As Object
    Dim annee As Integer
    Dim arr As Variant
    Dim i As Long
    Dim skey As String
    Dim skey1 As String
    Dim ws As Worksheet
    Dim rng As Range
    Dim t As Double

    t = Timer
    Set dict = CreateObject("scripting.dictionary")
    Set ws = ThisWorkbook.Sheets("Base_Capex")

    annee = ws.Range("B1").Value2
    MsgBox "Année en B1 : " & annee
    Set rng = ws.Range("F7:G36000")
    arr = rng.Value2

    Debug.Print "Année actuelle : " & annee
    Debug.Print "Plage de données : " & rng.Address

    For i = 1 To UBound(arr)
        skey = arr(i, 1) & "|" & arr(i, 2)
        Debug.Print "i = " & i & " | skey = " & skey

        If Len(skey) > 1 Then
            skey1 = arr(i, 1) & "|" & CStr(arr(i, 2) - 1)
            Debug.Print "skey1 (année précédente) = " & skey1

            If arr(i, 2) = annee Then
                If dict.exists(skey1) Then
                    Debug.Print "Données trouvées pour " & skey1
                    rng.Cells(i, 11).Resize(1, 33).Value = dict(skey1)
                Else
                    Debug.Print "Aucune donnée trouvée pour " & skey1
                End If
            End If

            dict(skey) = rng.Cells(i, 11).Resize(1, 33).Value2
            Debug.Print "Ajouté dans le dictionnaire : " & skey
        End If
    Next i

    MsgBox "Temps d'exécution : " & Timer - t & " secondes."
End Sub

Toutes les années sont ajoutées au dictionnaire et pas que l'année précédente.

Je ne comprends pas comment le code peux renvoyer sur l'année en cours la plage à récupérer.

Ci-joint, un fichier exemple un peu plus à l’échelle de mon projet.

Merci.

10test.zip (193.48 Ko)
Le 23/01/2025 à 13:36
9test-5.zip (208.82 Ko)
Le 23/01/2025 à 13:52

Salut Tespark,
Salut BsAlv,

une version plus adaptée mais 3 x plus lente que la macro de BsAlv.
@BsAlv : foutu Dico!

- double-clic sur [B1] = ma version avec des variables-tableaux
- clic droit sur [B1] = la version Dico de BsAlv

A+

12tespark.xlsm (1.27 Mo)
Le 23/01/2025 à 14:01

baiseur des millisecondes

14tespark-1.zip (406.94 Ko)
Le 23/01/2025 à 14:15

@BsAlv, ce ne sont plus des millisecondes, ça!
J'essaye de comprendre le truc mais mes neurones sont encore à la traîne en '84 !!

Le 23/01/2025 à 14:22

@BsAlv,

tiens, je t'ai gagné quelques précieuses millisecondes! 

               'With Range("F7:G" & .Range("B" & Rows.Count).End(xlUp).Row)
               With .Range("F" & .Columns("G").Find(what:=annee - 1).Row & ":G" & .Range("B" & Rows.Count).End(xlUp).Row)
Le 23/01/2025 à 15:45

Un grand merci à vous deux

Sur mon fichier de travail le code s'exécute en 95 S, mais cela me va très bien car il fait le job.

J'ai opté pour le dictionnaire :

Sub MAJ_Invest()
    Dim t As Double ' Pour mesurer le temps d'exécution
    Dim Target As Range ' La cellule ou plage ciblée (à définir dans le contexte)
    Dim dict As Object ' Dictionnaire pour stocker des valeurs uniques
    Dim annee As Long ' Année récupérée depuis la cellule B1
    Dim arr As Variant ' Tableau pour stocker les valeurs de la plage F7:G...
    Dim i As Long ' Compteur pour la boucle
    Dim skey As String ' Clé pour le dictionnaire (section et année)
    Dim skey1 As String ' Clé pour l'année précédente
    Dim cnt As Long ' Compteur de lignes traitées

    t = Timer
        Set dict = CreateObject("scripting.dictionary") ' Création du dictionnaire

        With Sheets("Base_Cpx")
            annee = .Range("B1").Value2 ' Récupération de l'année dans B1

            With .Range("F7:G" & .Range("B" & Rows.Count).End(xlUp).Row) ' Plage des données
                arr = .Value2 ' Stockage des données dans un tableau

                For i = 1 To UBound(arr) ' Boucle sur chaque ligne du tableau
                    skey = arr(i, 1) & "|" & arr(i, 2) ' Clé basée sur section et année

                    If Len(skey) > 1 Then
                        skey1 = arr(i, 1) & "|" & arr(i, 2) - 1 ' Clé pour l'année précédente

                        If arr(i, 2) = annee Then
                            If dict.exists(skey1) Then
                                .Cells(i, 11).Resize(, 33).Value = dict(skey1)
                                cnt = cnt + 1 ' Incrémentation du compteur de lignes traitées
                            End If
                        End If

                        With .Cells(i, 11).Resize(, 33)
                            If WorksheetFunction.CountA(.Offset(0)) > 0 Then
                                dict(skey) = .Value2 ' Ajout au dictionnaire si non vide
                            End If
                        End With
                    End If
                Next i
            End With
        End With

        MsgBox Timer - t & vbLf & cnt & " lignes" ' Affiche le temps d'exécution et le nombre de lignes traitées
End Sub

Milles merci à vous deux.

Le 23/01/2025 à 16:01

Salut Tespark,

90 sec !?
Pas possible, ça!
Essaye ceci, stp!
J'ai ajouté :
- Application.ScreenUpdating...
- un raccourci au tableau arr

Sub MAJ_Invest()
    Dim t As Double ' Pour mesurer le temps d'exécution
    Dim Target As Range ' La cellule ou plage ciblée (à définir dans le contexte)
    Dim dict As Object ' Dictionnaire pour stocker des valeurs uniques
    Dim annee As Long ' Année récupérée depuis la cellule B1
    Dim arr As Variant ' Tableau pour stocker les valeurs de la plage F7:G...
    Dim i As Long ' Compteur pour la boucle
    Dim skey As String ' Clé pour le dictionnaire (section et année)
    Dim skey1 As String ' Clé pour l'année précédente
    Dim cnt As Long ' Compteur de lignes traitées

    Application.ScreenUpdating = False
        Set dict = CreateObject("scripting.dictionary") ' Création du dictionnaire

        With Sheets("Base_Cpx")
            annee = .Range("B1").Value2 ' Récupération de l'année dans B1

            With .Range("F" & .Columns("G").Find(what:=annee-1).Row & ":G" & .Range("B" & Rows.Count).End(xlUp).Row) ' Plage des données
                arr = .Value2 ' Stockage des données dans un tableau

                For i = 1 To UBound(arr) ' Boucle sur chaque ligne du tableau
                    skey = arr(i, 1) & "|" & arr(i, 2) ' Clé basée sur section et année

                    If Len(skey) > 1 Then
                        skey1 = arr(i, 1) & "|" & arr(i, 2) - 1 ' Clé pour l'année précédente

                        If arr(i, 2) = annee Then
                            If dict.exists(skey1) Then
                                .Cells(i, 11).Resize(, 33).Value = dict(skey1)
                                cnt = cnt + 1 ' Incrémentation du compteur de lignes traitées
                            End If
                        End If

                        With .Cells(i, 11).Resize(, 33)
                            If WorksheetFunction.CountA(.Offset(0)) > 0 Then
                                dict(skey) = .Value2 ' Ajout au dictionnaire si non vide
                            End If
                        End With
                    End If
                Next i
            End With
        End With

        Application.ScreenUpdating = True
End Sub

Tu nous racontes ?

A+

Le 24/01/2025 à 16:25

Bonjour Curilus,

J'ai lancé le code que tu proposes et cela me fait gagner 25 S.

Le temps d'exécution et passer de 95 S à 70 S

Le 24/01/2025 à 16:30

Salut Tespark,

alors, question : au-delà de 2025, dans ton tableau... il y a combien de lignes? 2026, 2027...?

Le 25/01/2025 à 15:51

Bonjour Curulis,

Le tableau va de 2022 à 2025 en sachant que chaque année représente un peu plus de 7400 lignes.

Rechercher des sujets similaires à "recuperation donnees"