Synthétiser les données de 2 feuilles

Bonjour,

J'ai fais beaucoup de recherches pour essayer de trouver une réponse à ma question malheureusement je n'ai pas réussi à trouver ce que je cherche donc je crée ce sujet, j'espere qu'il n'existe pas déjà.

Alors je souhaite classer sur une feuille des données de deux autres feuilles. Il faudrait que cette feuille de synthèse soit capable de créer le nombre de ligne qu'il lui faut par catégorie et de reprendre deux données : le nom de la parcelle et sa surface.

C'est pas toujours très clair à l'écrit donc je joins un exemple de ce que je cherche à faire.

Merci beaucoup d'avance

12assolement.xlsx (23.49 Ko)

Bonjour,

en changeant la disposition et regroupant le tout, je vois ça ainsi

P.

11assolement-1.xlsx (20.23 Ko)

Bonjour,

Une proposition à étudier ! ...

Cdlt.

9assolement.xlsx (25.30 Ko)

Merci beaucoup de prendre de votre temps pour m'aider, le résultat obtenu est celui que je cherche mais j'aimerais ne pas avoir à changer la mise en forme de mes données car pour réaliser la rotation des cultures, c'est plus simple si une ligne = une parcelle et que les années se succèdent colonne après colonne.

Bonjour,

Une piste où les cultures qui n'existent pas seront rajoutées en fin de feuille avec mise en place des formules SOMME() en colonne B. Seules les dernières colonnes des deux feuilles sont prisent en compte (donc la dernière année).

La procédure et le classeur :

Sub Test()

    Dim Fe As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim CelTrouve As Range
    Dim Dico As Object
    Dim Cle As Variant
    Dim T
    Dim I As Long
    Dim J As Long
    Dim Lig As Long
    Dim Msg As String

    Set Dico = CreateObject("Scripting.Dictionary")

    'parcours les deux feuille
    For Each Fe In Worksheets(Array("ILOT A", "ILOT B"))

        With Fe

            'défini la plage sur la dernière colonne utilisée à partir de la ligne 2
            Set Plage = .Range(.Cells(2, .Cells(1, Columns.Count).End(xlToLeft).Column), _
                        .Cells(Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).End(xlUp))

            'stocke dans un dictionnaire les noms des parcelles et leurs surface, les paires sont
            'séparées par des traits verticaux et les valeurs des paires (nom et surface)
            'séparées par des point-virgules
            For Each Cel In Plage

                Dico(Cel.Value) = Dico(Cel.Value) & .Cells(Cel.Row, 1).Value & ";" & .Cells(Cel.Row, 2).Value & "|"

            Next Cel

        End With

    Next Fe

    With Worksheets("ASSOLEMENT")

        'boucle sur les clés...
        For Each Cle In Dico.Keys

            'récup des paires dans un tableau
            T = Split(Dico(Cle), "|")

            'recherche la clé dans la feuille...
            Set CelTrouve = .Columns("A:A").Find(Cle, , xlValues, xlWhole)

            'si trouvée...
            If Not CelTrouve Is Nothing Then

                'boucle sur les paires
                For I = 0 To UBound(T) - 1

                    'si la ligne de dessous n'est pas vide, insère une ligne et inscrit les valeurs
                    If CelTrouve.Offset(I + 1).Value <> "" Then

                        .Cells(CelTrouve.Row + I + 1, 1).EntireRow.Insert xlShiftDown
                        .Cells(CelTrouve.Row + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                        .Cells(CelTrouve.Row + I + 1, 2).Value = CDbl(Split(T(I), ";")(1)) 'surface

                    'si elle est vide, inscrit les valeurs sans insérer de ligne
                    Else

                        .Cells(CelTrouve.Row + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                        .Cells(CelTrouve.Row + I + 1, 2).Value = CDbl(Split(T(I), ";")(1))  'surface

                    End If

                Next I

                'inscrit la formule de sommage
                .Cells(CelTrouve.Row, 2).Formula = "=SUM(B" & CelTrouve.Row + 1 & ":B" & CelTrouve.Row + I & ")"
                .Cells(CelTrouve.Row, 2).Font.Bold = True

            'si la clé n'est pas trouvée, message et création de la clé (culture) avec un écart de
            'deux lignes dans le bas de la feuille
            Else

                Msg = Msg & Cle & vbCrLf

                Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 2

                .Cells(Lig, 1).Value = Cle
                .Cells(Lig, 1).Font.Bold = True

                For I = 0 To UBound(T) - 1

                    .Cells(Lig + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                    .Cells(Lig + I + 1, 2).Value = CDbl(Split(T(I), ";")(1)) 'surface

                Next I

                'inscrit la formule de sommage
                .Cells(Lig, 2).Formula = "=SUM(B" & Lig + 1 & ":B" & Lig + I & ")"
                .Cells(Lig, 2).Font.Bold = True

            End If

        Next Cle

    End With

    If Msg <> "" Then

        MsgBox "La (les) culture(s) ci-dessous n'existe(nt) pas dans la feuille 'ASSOLEMENT' !" & _
               vbCrLf & _
               "Elle(s) a (ont) été ajoutée(s) sur la feuille à la suite des autres cultures." & _
               vbCrLf & _
               Msg

    End If

End Sub
11assolement.xlsm (24.15 Ko)

RE,

Bonjour Theze,

Pas de Dictionary sous Mac, si je ne me trompe pas ! ...

Cdlt.

Bonjour Jean-Eric,

Zut, je n'ai pas fais attention

Donc, à oublier

Wouah je suis stupéfait de l'entraide sur ce forum!

Dommage que ça ne fonctionne pas sur mac car vous avez du y passer du temps !!

Merci beaucoup

Bonjour Jean-Eric,

Zut, je n'ai pas fais attention

Donc, à oublier

Bonjour,

tu peux remplacer par collection si je ne trompe mais je ne sais pas si tout est pareil

P.

Merci beaucoup de prendre de votre temps pour m'aider, le résultat obtenu est celui que je cherche mais j'aimerais ne pas avoir à changer la mise en forme de mes données car pour réaliser la rotation des cultures, c'est plus simple si une ligne = une parcelle et que les années se succèdent colonne après colonne.

Bonjour,

Les solutions proposées par Jean-Eric et moi sont pareilles ce qui montre (peut être) que c'est comme ça que tu dois encoder tes données qui sont ensuite sans difficultés se placer en TCD que tu peux facilement modifier SANS que cela ne touche à tes données de base...

P.

Merci beaucoup de prendre de votre temps pour m'aider, le résultat obtenu est celui que je cherche mais j'aimerais ne pas avoir à changer la mise en forme de mes données car pour réaliser la rotation des cultures, c'est plus simple si une ligne = une parcelle et que les années se succèdent colonne après colonne.

Bonjour,

Les solutions proposées par Jean-Eric et moi sont pareilles ce qui montre (peut être) que c'est comme ça que tu dois encoder tes données qui pourront ensuite sans difficultés se placer en TCD que tu peux facilement modifier SANS que cela ne touche à tes données de base...

P.

Oui peut être mais ca serait vraiment pas pratique et je serais gagnant de faire le récap manuellement que de devoir organiser différemment les premieres feuilles :/

Et pour ton idée de "collection" comment faudrait il modifier le code pour le mettre à la place de dictionnaire ?

Bonjour,

Je n'ai pas pris le risque d'utiliser une collection donc, voici le code avec un tableau à deux dimensions et une fonction de contrôle d'existence de l'élément. J'espère que ça va fonctionner avec Excel pour Mac :

Sub Test()

    Dim Tbl() As String
    Dim Fe As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim CelTrouve As Range
    Dim Pos As Long
    Dim T
    Dim I As Long
    Dim J As Long
    Dim K As Long
    Dim Lig As Long
    Dim Msg As String

    'parcours les deux feuille
    For Each Fe In Worksheets(Array("ILOT A", "ILOT B"))

        With Fe

            'défini la plage sur la dernière colonne utilisée à partir de la ligne 2
            Set Plage = .Range(.Cells(2, .Cells(1, Columns.Count).End(xlToLeft).Column), _
                        .Cells(Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).End(xlUp))

            'stocke dans un tableau les noms des parcelles et leurs surface, les paires sont
            'séparées par des traits verticaux et les valeurs des paires (nom et surface)
            'séparées par des point-virgules
            For Each Cel In Plage

                If Existe(Tbl, Cel.Value, Pos) Then

                    Tbl(2, Pos) = Tbl(2, Pos) & .Cells(Cel.Row, 1).Value & ";" & .Cells(Cel.Row, 2).Value & "|"

                Else

                    K = K + 1: ReDim Preserve Tbl(1 To 2, 1 To K)
                    Tbl(1, K) = Cel.Value
                    Tbl(2, K) = .Cells(Cel.Row, 1).Value & ";" & .Cells(Cel.Row, 2).Value & "|"

                End If

            Next Cel

        End With

    Next Fe

    With Worksheets("ASSOLEMENT")

        'boucle sur le tableau...
        For K = 1 To UBound(Tbl, 2)

            'récup des paires dans un autre tableau
            T = Split(Tbl(2, K), "|")

            'recherche la valeur dans la feuille...
            Set CelTrouve = .Columns("A:A").Find(Tbl(1, K), , xlValues, xlWhole)

            'si trouvée...
            If Not CelTrouve Is Nothing Then

                'boucle sur les paires
                For I = 0 To UBound(T) - 1

                    'si la ligne de dessous n'est pas vide, insère une ligne et inscrit les valeurs
                    If CelTrouve.Offset(I + 1).Value <> "" Then

                        .Cells(CelTrouve.Row + I + 1, 1).EntireRow.Insert xlShiftDown
                        .Cells(CelTrouve.Row + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                        .Cells(CelTrouve.Row + I + 1, 2).Value = CDbl(Split(T(I), ";")(1)) 'surface

                    'si elle est vide, inscrit les valeurs sans insérer de ligne
                    Else

                        .Cells(CelTrouve.Row + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                        .Cells(CelTrouve.Row + I + 1, 2).Value = CDbl(Split(T(I), ";")(1))  'surface

                    End If

                Next I

                'inscrit la formule de sommage
                .Cells(CelTrouve.Row, 2).Formula = "=SUM(B" & CelTrouve.Row + 1 & ":B" & CelTrouve.Row + I & ")"
                .Cells(CelTrouve.Row, 2).Font.Bold = True

            'si la clé n'est pas trouvée, message et création de la clé (culture) avec un écart de
            'deux lignes dans le bas de la feuille
            Else

                Msg = Msg & Tbl(1, K) & vbCrLf

                Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 2

                .Cells(Lig, 1).Value = Tbl(1, K)
                .Cells(Lig, 1).Font.Bold = True

                For I = 0 To UBound(T) - 1

                    .Cells(Lig + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                    .Cells(Lig + I + 1, 2).Value = CDbl(Split(T(I), ";")(1)) 'surface

                Next I

                'inscrit la formule de sommage
                .Cells(Lig, 2).Formula = "=SUM(B" & Lig + 1 & ":B" & Lig + I & ")"
                .Cells(Lig, 2).Font.Bold = True

            End If

        Next K

    End With

    If Msg <> "" Then

        MsgBox "La (les) culture(s) ci-dessous n'existe(nt) pas dans la feuille 'ASSOLEMENT' !" & _
               vbCrLf & _
               "Elle(s) a (ont) été ajoutée(s) sur la feuille à la suite des autres cultures." & _
               vbCrLf & _
               Msg

    End If

End Sub

Function Existe(Tablo() As String, Element As String, Pos As Long) As Boolean

    Dim I As Long

    If Not (Not Tablo()) Then

        For I = 1 To UBound(Tablo, 2)

            If Tablo(1, I) = Element Then

                Existe = True
                Pos = I
                Exit Function

            End If

        Next I

    Else

        Existe = False

    End If

End Function

Oui peut être mais ca serait vraiment pas pratique et je serais gagnant de faire le récap manuellement que de devoir organiser différemment les premieres feuilles :/

Et pour ton idée de "collection" comment faudrait il modifier le code pour le mettre à la place de dictionnaire ?

Tout comme Theze (que je salue) Je ne ma lancerai pas non plus dans les collections (:D ) mais je me demande si tu as tant de données que ça à modifier ?

Une fois placées en colonnes, tu as beaucoup plus de facilité avec les TCD et sans programmation no formules complexes

P.

Bonjour,

Je n'ai pas pris le risque d'utiliser une collection donc, voici le code avec un tableau à deux dimensions et une fonction de contrôle d'existence de l'élément. J'espère que ça va fonctionner avec Excel pour Mac :

Sub Test()

    Dim Tbl() As String
    Dim Fe As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim CelTrouve As Range
    Dim Pos As Long
    Dim T
    Dim I As Long
    Dim J As Long
    Dim K As Long
    Dim Lig As Long
    Dim Msg As String

    'parcours les deux feuille
    For Each Fe In Worksheets(Array("ILOT A", "ILOT B"))

        With Fe

            'défini la plage sur la dernière colonne utilisée à partir de la ligne 2
            Set Plage = .Range(.Cells(2, .Cells(1, Columns.Count).End(xlToLeft).Column), _
                        .Cells(Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).End(xlUp))

            'stocke dans un tableau les noms des parcelles et leurs surface, les paires sont
            'séparées par des traits verticaux et les valeurs des paires (nom et surface)
            'séparées par des point-virgules
            For Each Cel In Plage

                If Existe(Tbl, Cel.Value, Pos) Then

                    Tbl(2, Pos) = Tbl(2, Pos) & .Cells(Cel.Row, 1).Value & ";" & .Cells(Cel.Row, 2).Value & "|"

                Else

                    K = K + 1: ReDim Preserve Tbl(1 To 2, 1 To K)
                    Tbl(1, K) = Cel.Value
                    Tbl(2, K) = .Cells(Cel.Row, 1).Value & ";" & .Cells(Cel.Row, 2).Value & "|"

                End If

            Next Cel

        End With

    Next Fe

    With Worksheets("ASSOLEMENT")

        'boucle sur le tableau...
        For K = 1 To UBound(Tbl, 2)

            'récup des paires dans un autre tableau
            T = Split(Tbl(2, K), "|")

            'recherche la valeur dans la feuille...
            Set CelTrouve = .Columns("A:A").Find(Tbl(1, K), , xlValues, xlWhole)

            'si trouvée...
            If Not CelTrouve Is Nothing Then

                'boucle sur les paires
                For I = 0 To UBound(T) - 1

                    'si la ligne de dessous n'est pas vide, insère une ligne et inscrit les valeurs
                    If CelTrouve.Offset(I + 1).Value <> "" Then

                        .Cells(CelTrouve.Row + I + 1, 1).EntireRow.Insert xlShiftDown
                        .Cells(CelTrouve.Row + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                        .Cells(CelTrouve.Row + I + 1, 2).Value = CDbl(Split(T(I), ";")(1)) 'surface

                    'si elle est vide, inscrit les valeurs sans insérer de ligne
                    Else

                        .Cells(CelTrouve.Row + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                        .Cells(CelTrouve.Row + I + 1, 2).Value = CDbl(Split(T(I), ";")(1))  'surface

                    End If

                Next I

                'inscrit la formule de sommage
                .Cells(CelTrouve.Row, 2).Formula = "=SUM(B" & CelTrouve.Row + 1 & ":B" & CelTrouve.Row + I & ")"
                .Cells(CelTrouve.Row, 2).Font.Bold = True

            'si la clé n'est pas trouvée, message et création de la clé (culture) avec un écart de
            'deux lignes dans le bas de la feuille
            Else

                Msg = Msg & Tbl(1, K) & vbCrLf

                Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 2

                .Cells(Lig, 1).Value = Tbl(1, K)
                .Cells(Lig, 1).Font.Bold = True

                For I = 0 To UBound(T) - 1

                    .Cells(Lig + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                    .Cells(Lig + I + 1, 2).Value = CDbl(Split(T(I), ";")(1)) 'surface

                Next I

                'inscrit la formule de sommage
                .Cells(Lig, 2).Formula = "=SUM(B" & Lig + 1 & ":B" & Lig + I & ")"
                .Cells(Lig, 2).Font.Bold = True

            End If

        Next K

    End With

    If Msg <> "" Then

        MsgBox "La (les) culture(s) ci-dessous n'existe(nt) pas dans la feuille 'ASSOLEMENT' !" & _
               vbCrLf & _
               "Elle(s) a (ont) été ajoutée(s) sur la feuille à la suite des autres cultures." & _
               vbCrLf & _
               Msg

    End If

End Sub

Function Existe(Tablo() As String, Element As String, Pos As Long) As Boolean

    Dim I As Long

    If Not (Not Tablo()) Then

        For I = 1 To UBound(Tablo, 2)

            If Tablo(1, I) = Element Then

                Existe = True
                Pos = I
                Exit Function

            End If

        Next I

    Else

        Existe = False

    End If

End Function

Super boulot ça fonctionne super bien mille merci

Le seul problème (mais c'est ma faute), c'est que je ne comprends pas vraiment comme ça fonctionne donc j'ai un peu de mal à le modifier :/

Il me faudrait juste une précision :

  • Comment faire pour changer l'année de l'assolement pour avoir une feuille d'assolement par année.
  • Comment faire pour insérer une colonne entre le nom et la surface (une colonne ou je met mon système d'irrigation simplement pour mémoire qui n'influe pas sur tout ça)

Encore merci c'est top !!

3assolement.xlsm (31.32 Ko)

Bonjour,

Je te re poste tout le code car j'ai fais les modifs et j'ai rajouté une fonction de contrôle d'existence de feuille car un InputBox() demande l'année voulue. Le code existant est entièrement à remplacer par celui-ci-dessous (j'espère que ça va marcher !) :

Sub Test()

    Dim Tbl() As String
    Dim Fe As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim CelTrouve As Range
    Dim Pos As Long
    Dim T
    Dim I As Long
    Dim J As Long
    Dim K As Long
    Dim Lig As Long
    Dim Msg As String
    Dim Annee As String

    'parcours les deux feuille
    For Each Fe In Worksheets(Array("ILOT A", "ILOT B"))

        With Fe

            'défini la plage sur la dernière colonne utilisée à partir de la ligne 2
            Set Plage = .Range(.Cells(2, .Cells(1, Columns.Count).End(xlToLeft).Column), _
                        .Cells(Rows.Count, .Cells(1, Columns.Count).End(xlToLeft).Column).End(xlUp))

            'stocke dans un tableau les noms des parcelles et leurs surface, les paires sont
            'séparées par des traits verticaux et les valeurs des paires (nom et surface)
            'séparées par des point-virgules
            For Each Cel In Plage

                If Existe(Tbl, Cel.Value, Pos) Then

                    'ici, ".Cells(Cel.Row, 1)" le 1 représente la colonne A où se trouve le nom de la parcelle
                    'et ici, ".Cells(Cel.Row, 3)" le 3 représente la colonne C où se trouve maintenant la surface
                    Tbl(2, Pos) = Tbl(2, Pos) & .Cells(Cel.Row, 1).Value & ";" & .Cells(Cel.Row, 3).Value & "|"

                Else

                    K = K + 1: ReDim Preserve Tbl(1 To 2, 1 To K)
                    Tbl(1, K) = Cel.Value
                    Tbl(2, K) = .Cells(Cel.Row, 1).Value & ";" & .Cells(Cel.Row, 3).Value & "|"

                End If

            Next Cel

        End With

    Next Fe

    'demande l'année
    Annee = InputBox("Quelle année ?", "Choix de l'année.", Year(Date))

    'effectue un contrôle d'existance et si non, message et fin
    If FeuilleExiste("ASSOLEMENT " & Annee) = False Then MsgBox "La feuille 'ASSOLEMENT " & Annee & "' n'existe pas !": Exit Sub

    With Worksheets("ASSOLEMENT " & Annee)

        .Range(.Cells(4, 1), .Cells(Rows.Count, 6)).Font.Bold = False

        'boucle sur le tableau...
        For K = 1 To UBound(Tbl, 2)

            'récup des paires dans un autre tableau
            T = Split(Tbl(2, K), "|")

            'recherche la valeur dans la feuille...
            Set CelTrouve = .Columns("A:A").Find(Tbl(1, K), , xlValues, xlWhole)

            'si trouvée...
            If Not CelTrouve Is Nothing Then

                'boucle sur les paires
                For I = 0 To UBound(T) - 1

                    'si la ligne de dessous n'est pas vide, insère une ligne et inscrit les valeurs
                    If CelTrouve.Offset(I + 1).Value <> "" Then

                        .Cells(CelTrouve.Row + I + 1, 1).EntireRow.Insert xlShiftDown
                        .Cells(CelTrouve.Row + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                        .Cells(CelTrouve.Row + I + 1, 2).Value = CDbl(Split(T(I), ";")(1)) 'surface

                    'si elle est vide, inscrit les valeurs sans insérer de ligne
                    Else

                        .Cells(CelTrouve.Row + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                        .Cells(CelTrouve.Row + I + 1, 2).Value = CDbl(Split(T(I), ";")(1))  'surface

                    End If

                Next I

                'inscrit la formule de sommage
                .Cells(CelTrouve.Row, 2).Formula = "=SUM(B" & CelTrouve.Row + 1 & ":B" & CelTrouve.Row + I & ")"
                .Cells(CelTrouve.Row, 2).Font.Bold = True

            'si la clé n'est pas trouvée, message et création de la clé (culture) avec un écart de
            'deux lignes dans le bas de la feuille
            Else

                Msg = Msg & Tbl(1, K) & vbCrLf

                Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 2

                .Cells(Lig, 1).Value = Tbl(1, K)
                .Cells(Lig, 1).Font.Bold = True

                For I = 0 To UBound(T) - 1

                    .Cells(Lig + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                    .Cells(Lig + I + 1, 2).Value = CDbl(Split(T(I), ";")(1)) 'surface

                Next I

                'inscrit la formule de sommage
                .Cells(Lig, 2).Formula = "=SUM(B" & Lig + 1 & ":B" & Lig + I & ")"
                .Cells(Lig, 2).Font.Bold = True

            End If

        Next K

    End With

    If Msg <> "" Then

        MsgBox "La (les) culture(s) ci-dessous n'existe(nt) pas dans la feuille 'ASSOLEMENT " & Annee & "' !" & _
               vbCrLf & _
               "Elle(s) a (ont) été ajoutée(s) sur la feuille à la suite des autres cultures." & _
               vbCrLf & _
               Msg

    End If

End Sub

Function Existe(Tablo() As String, Element As String, Pos As Long) As Boolean

    Dim I As Long

    If Not (Not Tablo()) Then

        For I = 1 To UBound(Tablo, 2)

            If Tablo(1, I) = Element Then

                Existe = True
                Pos = I
                Exit Function

            End If

        Next I

    Else

        Existe = False

    End If

End Function

Function FeuilleExiste(NomFeuille As String) As Boolean

    Dim Fe As Worksheet

    For Each Fe In Worksheets

        If Fe.Name = NomFeuille Then

            FeuilleExiste = True
            Exit Function

        End If

    Next Fe

End Function

Je joins aussi le classeur avec le code complet :

Wouah c'est parfait ça

Il y a juste un petit soucis c'est que peu importe le nom du classeur et l'année que j'entre dans la boite, ça me met toujours les cultures de l'année 2019 :/

Bonjour,

Remplacer juste la procédure " Test" par celle-ci-dessous :

Sub Test()

    Dim Tbl() As String
    Dim Fe As Worksheet
    Dim Plage As Range
    Dim PlgCulture As Range
    Dim Cel As Range
    Dim CelTrouve As Range
    Dim Pos As Long
    Dim T
    Dim I As Long
    Dim J As Long
    Dim K As Long
    Dim Lig As Long
    Dim Msg As String
    Dim Annee As String

    'demande l'année
    Annee = InputBox("Quelle année ?", "Choix de l'année.", Year(Date))

    'effectue un contrôle d'existance et si non, message et fin
    If FeuilleExiste("ASSOLEMENT " & Annee) = False Then MsgBox "La feuille 'ASSOLEMENT " & Annee & "' n'existe pas !": Exit Sub

    'parcours les deux feuille
    For Each Fe In Worksheets(Array("ILOT A", "ILOT B"))

        With Fe

            Set PlgCulture = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
            Set Cel = PlgCulture.Find("Culture " & Annee, , xlValues, xlWhole)

            If Cel Is Nothing Then MsgBox "La culture de l'année " & Annee & " n'existe pas sur la feuille " & Fe.Name & " !": Exit Sub

            'défini la plage sur la dernière colonne utilisée à partir de la ligne 2
            Set Plage = .Range(.Cells(2, Cel.Column), .Cells(.Rows.Count, Cel.Column).End(xlUp))

            'stocke dans un tableau les noms des parcelles et leurs surface, les paires sont
            'séparées par des traits verticaux et les valeurs des paires (nom et surface)
            'séparées par des point-virgules
            For Each Cel In Plage

                If Existe(Tbl, Cel.Value, Pos) Then

                    'ici, ".Cells(Cel.Row, 1)" le 1 représente la colonne A où se trouve le nom de la parcelle
                    'et ici, ".Cells(Cel.Row, 3)" le 3 représente la colonne C où se trouve maintenant la surface
                    Tbl(2, Pos) = Tbl(2, Pos) & .Cells(Cel.Row, 1).Value & ";" & .Cells(Cel.Row, 3).Value & "|"

                Else

                    K = K + 1: ReDim Preserve Tbl(1 To 2, 1 To K)
                    Tbl(1, K) = Cel.Value
                    Tbl(2, K) = .Cells(Cel.Row, 1).Value & ";" & .Cells(Cel.Row, 3).Value & "|"

                End If

            Next Cel

        End With

    Next Fe

    With Worksheets("ASSOLEMENT " & Annee)

        .Range(.Cells(4, 1), .Cells(Rows.Count, 6)).Font.Bold = False

        'boucle sur le tableau...
        For K = 1 To UBound(Tbl, 2)

            'récup des paires dans un autre tableau
            T = Split(Tbl(2, K), "|")

            'recherche la valeur dans la feuille...
            Set CelTrouve = .Columns("A:A").Find(Tbl(1, K), , xlValues, xlWhole)

            'si trouvée...
            If Not CelTrouve Is Nothing Then

                'boucle sur les paires
                For I = 0 To UBound(T) - 1

                    'si la ligne de dessous n'est pas vide, insère une ligne et inscrit les valeurs
                    If CelTrouve.Offset(I + 1).Value <> "" Then

                        .Cells(CelTrouve.Row + I + 1, 1).EntireRow.Insert xlShiftDown
                        .Cells(CelTrouve.Row + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                        .Cells(CelTrouve.Row + I + 1, 2).Value = CDbl(Split(T(I), ";")(1)) 'surface

                    'si elle est vide, inscrit les valeurs sans insérer de ligne
                    Else

                        .Cells(CelTrouve.Row + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                        .Cells(CelTrouve.Row + I + 1, 2).Value = CDbl(Split(T(I), ";")(1))  'surface

                    End If

                Next I

                'inscrit la formule de sommage
                .Cells(CelTrouve.Row, 2).Formula = "=SUM(B" & CelTrouve.Row + 1 & ":B" & CelTrouve.Row + I & ")"
                .Cells(CelTrouve.Row, 2).Font.Bold = True

            'si la clé n'est pas trouvée, message et création de la clé (culture) avec un écart de
            'deux lignes dans le bas de la feuille
            Else

                Msg = Msg & Tbl(1, K) & vbCrLf

                Lig = .Cells(.Rows.Count, 1).End(xlUp).Row + 2

                .Cells(Lig, 1).Value = Tbl(1, K)
                .Cells(Lig, 1).Font.Bold = True

                For I = 0 To UBound(T) - 1

                    .Cells(Lig + I + 1, 1).Value = Split(T(I), ";")(0) 'parcelle
                    .Cells(Lig + I + 1, 2).Value = CDbl(Split(T(I), ";")(1)) 'surface

                Next I

                'inscrit la formule de sommage
                .Cells(Lig, 2).Formula = "=SUM(B" & Lig + 1 & ":B" & Lig + I & ")"
                .Cells(Lig, 2).Font.Bold = True

            End If

        Next K

    End With

    If Msg <> "" Then

        MsgBox "La (les) culture(s) ci-dessous n'existe(nt) pas dans la feuille 'ASSOLEMENT " & Annee & "' !" & _
               vbCrLf & _
               "Elle(s) a (ont) été ajoutée(s) sur la feuille à la suite des autres cultures." & _
               vbCrLf & _
               Msg

    End If

End Sub

C'est juste parfait, je sais pas comment te remercier ...

Merci à tous ceux qui ont pris le temps de m'aider et particulièrement à toi pour le super coup de main !!

C'est vrai super gentil à vous tous de prendre sur votre temps libre pour rendre service

EDIT : Oups une dernière question et promis j'arrête de t'embeter !

A la suite de la liste de mes parcelles sur les feuilles ilots, j'ai d'autres données qui n'ont rien à voir, est ce que je peux dire au programme de récupérer les parcelles de la ligne 2 à X pour éviter que ça bug quand il se rend compte que la disposition ne correspond plus ?

Bonjour,

A la suite de la liste de mes parcelles sur les feuilles ilots, j'ai d'autres données qui n'ont rien à voir, est ce que je peux dire au programme de récupérer les parcelles de la ligne 2 à X pour éviter que ça bug quand il se rend compte que la disposition ne correspond plus ?

Et bien, si ces valeurs sont séparées des autres par au moins une ligne vide, tu peux utiliser la ligne de code ci-dessous pour ne récupérer que la plage de la cellule en ligne 2 à la dernière cellule non vide de la même colonne donc, cette ligne de code :

Set Plage = .Range(.Cells(2, Cel.Column), .Cells(2, Cel.Column).End(xlDown))

remplace celle-ci :

Set Plage = .Range(.Cells(2, Cel.Column), .Cells(.Rows.Count, Cel.Column).End(xlUp))

(4ème lignes sous "With Fe")

Rechercher des sujets similaires à "synthetiser donnees feuilles"