Microsoft 365 Macro Excel pour effectuer des opérations sur les lignes et cellules adjacentes

[Perceval973]

Bonjour à tous,

J'ai un classeur contenant énormément de données, sur trois colonnes, que j'ai besoin de comparer et sommer suivant le schéma suivant :

Colonne A : références / Colonne B : Désignations / Colonne C : durées
SI A2=A1 ALORS concaténer B1 et B2 ET sommer C1 et C2

Ceci jusqu'à ce que la cellule An soit vide
Le résultat peut soit remplacer les données du tableau ET supprimer les lignes déjà prises en compte, soit faire l'objet d'un nouveau tableau à coté du premier

Merci pour votre aide 🙂
Perceval

 

[Perceval973]

A toi de choisir :
> Cette macro exporte les données dans une nouvelle feuille : Pas de mise à jour du résultat si l'on modifie les données de départ
> Cette macro génère la formule "=LET(m1r..." dans une nouvelle feuille : Mise à jour du résultat si l'on modifie les données de départ

Concernant le tableau de départ :
> On considère qu'il commence toujours en A1
> Ou que l'utilisateur doit cliquer dedans (peut ainsi être positionné ailleurs que A1)

Le tableau de départ commence toujours en A1

Je n'ai pas besoin d'une mise a jour du résultat si l'on modifie les données de départ (on ne les modifie pas)

 

[Perceval973]

A toi de choisir :
> Cette macro exporte les données dans une nouvelle feuille : Pas de mise à jour du résultat si l'on modifie les données de départ
> Cette macro génère la formule "=LET(m1r..." dans une nouvelle feuille : Mise à jour du résultat si l'on modifie les données de départ

Concernant le tableau de départ :
> On considère qu'il commence toujours en A1
> Ou que l'utilisateur doit cliquer dedans (peut ainsi être positionné ailleurs que A1)

J'ai peur de ne pas avoir compris
Tu dis "cette macro" comme si elle etait dans ton message, mais je ne vois rien :-/

 

[Hecatonchire]

Non il n'y a pas de macro dans le message : "cette" = la futur macro

Je préfère savoir le résultat attendu avant de proposer un résultat 🤔

 

[Hecatonchire]

Je n'ai pas voulu réinventer quelque chose de nouveau donc je suis parti de la formule Let comme base.
A toi de compléter la code (ajout d'entête, mise en forme, renommer la feuille...)

Sub Export()
    Dim objFeuilleActive        As Worksheet
    Dim lgFinTab                As Long     ' N° de la dernière ligne
    Dim strPlageA               As String
    Dim strPlageB               As String
    Dim strPlageC               As String
    Dim rgPlage                 As Range    ' Plage résultat
    Dim tabPlage()                          ' Tableau pour écraser la formule
    
    Application.ScreenUpdating = False
    lgFinTab = [A1].End(xlDown).Row
    strPlageA = "'" & ActiveSheet.Name & "'!A2:A" & lgFinTab
    strPlageB = "'" & ActiveSheet.Name & "'!B2:B" & lgFinTab
    strPlageC = "'" & ActiveSheet.Name & "'!C2:C" & lgFinTab
    
    Set objNouvelleFeuille = ActiveWorkbook.Worksheets.Add
    objNouvelleFeuille.Range("A2").Formula2Local = "=LET(m1r;UNIQUE(" & strPlageA & ");" & _
                "m2r;MAP(m1r;LAMBDA(v;JOINDRE.TEXTE("" > "";VRAI;FILTRE(" & strPlageB & ";" & strPlageA & "=v))));" & _
                "m3r;MAP(m1r;LAMBDA(v;SOMME(FILTRE(" & strPlageC & ";" & strPlageA & "=v))));" & _
                "ASSEMB.H(m1r;m2r;m3r))"
    ' On écrase la formule
    Set rgPlage = objNouvelleFeuille.[A2].CurrentRegion
    tabPlage = rgPlage.Value
    rgPlage.Value = tabPlage
    ' Nettoyage
    objNouvelleFeuille.Columns("A:C").EntireColumn.AutoFit
    Set rgPlage = Nothing
    Set objNouvelleFeuille = Nothing
    Application.ScreenUpdating = True
End Sub

 

[Perceval973]

Je n'ai pas voulu réinventer quelque chose de nouveau donc je suis parti de la formule Let comme base.
A toi de compléter la code (ajout d'entête, mise en forme, renommer la feuille...)

Sub Export()
    Dim objFeuilleActive        As Worksheet
    Dim lgFinTab                As Long     ' N° de la dernière ligne
    Dim strPlageA               As String
    Dim strPlageB               As String
    Dim strPlageC               As String
    Dim rgPlage                 As Range    ' Plage résultat
    Dim tabPlage()                          ' Tableau pour écraser la formule
   
    Application.ScreenUpdating = False
    lgFinTab = [A1].End(xlDown).Row
    strPlageA = "'" & ActiveSheet.Name & "'!A2:A" & lgFinTab
    strPlageB = "'" & ActiveSheet.Name & "'!B2:B" & lgFinTab
    strPlageC = "'" & ActiveSheet.Name & "'!C2:C" & lgFinTab
   
    Set objNouvelleFeuille = ActiveWorkbook.Worksheets.Add
    objNouvelleFeuille.Range("A2").Formula2Local = "=LET(m1r;UNIQUE(" & strPlageA & ");" & _
                "m2r;MAP(m1r;LAMBDA(v;JOINDRE.TEXTE("" > "";VRAI;FILTRE(" & strPlageB & ";" & strPlageA & "=v))));" & _
                "m3r;MAP(m1r;LAMBDA(v;SOMME(FILTRE(" & strPlageC & ";" & strPlageA & "=v))));" & _
                "ASSEMB.H(m1r;m2r;m3r))"
    ' On écrase la formule
    Set rgPlage = objNouvelleFeuille.[A2].CurrentRegion
    tabPlage = rgPlage.Value
    rgPlage.Value = tabPlage
    ' Nettoyage
    objNouvelleFeuille.Columns("A:C").EntireColumn.AutoFit
    Set rgPlage = Nothing
    Set objNouvelleFeuille = Nothing
    Application.ScreenUpdating = True
End Sub

Cela fonctionne parfaitement, je te remercie...
Bon, mes connaissances sont insuffisantes pour être capable de renommer la nouvelle feuille, mais tu m'as déjà beaucoup aidé