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
Bonjour,
en changeant la disposition et regroupant le tout, je vois ça ainsi
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,
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
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
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 !!
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")