VBA - remplissage tableau sous conditions
d
Bonjour à tous.
Après plusieurs jours de recherche ici et ailleurs, je n'ai toujours pas réussi à résoudre mon problème.
Alors je me tourne vers vous pour que vous puissiez m'aider à le résoudre.
Voici mon problème:
J'ai un fichier Excel (exemple) avec une feuille "Synthèse" et une feuille "OTA55".
En activant ma feuille "OTA55", j'aimerais que les données de la feuille "Synthèse" s'importent automatiquement sous condition.
condition 1 : Il faut que les données importées correspondent bien au critère de sélection (ici OTA55 - nom de la feuille)
condition 2 : Il ne faut pas que les données à importer qui se trouvent sur une ligne fasse un doublon avec une ligne de la feuille OTA55. Pour cela j'ai créé une clé en concaténant les données de plusieurs cellules sur la feuille "Synthèse" et la Feuille "OTA55".
Les divers problèmes que je rencontre:
1) je ne balaie pas ma feuille "Synthèse". Je reste toujours sur la même ligne
2) je ne balaie pas ma feuille "OTA55". C'est toujours la même ligne qui est importée et toujours à la même place.
Voici le code de mon module pour l'import:
Option Explicit
Dim Compo As Variant 'variable de la cellule C9 de la page activée
Dim CelluleTrouve As Variant 'variable C9 à recherchée dans synthese
Dim Plage As Range 'plage de recherche dynamique
Dim Cle1 As Variant 'variable contenant concatenation synthese
Dim Matrice As String 'matrice
Dim X As Variant 'X des labos
Dim uX As Variant 'uX des labos
Dim sX As Variant 'sX des labos
Dim ResultLabo As Variant 'results labo
Dim Circuit As Variant 'circuit
Dim Essai As Variant 'essai
Dim Fabrication As Variant 'numero d'identification
Dim Cellule As Variant 'cellule actice dans la feuille activée
Dim Cle2 As Variant 'variable contenant concatenation selectionnée
Public Sub RemplirTabl(WshA As Variant)
Application.EnableEvents = False
'activation mise à jour écran
Application.ScreenUpdating = False
'retrait protection
Sheets("Synthese").Unprotect
Sheets(WshA).Unprotect
'attribuer la valeur C9 de la feuille choisie
Compo = ""
Compo = ThisWorkbook.Sheets(WshA).Range("C9").Value
'Verification et remplissage du tableau de la feuille selectionnée
With Sheets("Synthese")
'mise à zero des 2 variables et definition de la plage de cellule
CelluleTrouve = ""
Cle1 = ""
Set Plage = ThisWorkbook.Sheets("Synthese").Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row)
'boucle sur la colonne F de la feuille synthese pour recherche de la valeur C9
For Each CelluleTrouve In Plage
Set CelluleTrouve = Plage.Find(what:=Compo, LookIn:=xlValues, lookat:=xlWhole)
'si la valeur est trouvée
If Not CelluleTrouve Is Nothing Then
'defini les différentes valeurs à copier dans le tableau
Cle1 = CelluleTrouve.Offset(, 21).Value 'valeur de la concatenation matrice X uX sX Xlabo....
Matrice = CelluleTrouve.Offset(, -2).Value
X = CelluleTrouve.Offset(, 3).Value
uX = CelluleTrouve.Offset(, 4).Value
sX = CelluleTrouve.Offset(, 5).Value
ResultLabo = CelluleTrouve.Offset(, 16).Value
Circuit = CelluleTrouve.Offset(, -5).Value
Essai = CelluleTrouve.Offset(, -4).Value
Fabrication = CelluleTrouve.Offset(, -3).Value
'sur la feuille selectionnée
With Sheets(WshA)
'mise à zero des variables
'Cellule = ""
Cle2 = ""
'boucle pour verifier si la valeur cellule trouvée existe déjà
For Each Cellule In Sheets(WshA).Range("CQ16:CQ65")
'copie
Cellule.Copy
'collage spécial valeur mais pas formule
Cellule.Offset(, 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'attribution de la valeur clé2
Cle2 = Cellule.Offset(, 1).Value 'valeur de la concatenation matrice X uX sX Xlabo...
'verifie cle2 n'est pas vide
If Cle2 <> "" Then
If Cle2 Like Cle1 Then 'verifie si cle2 = cle1
'GoTo A
Cellule = Cellule.Offset(1, 0)
Exit For 'sortie boucle feuille selectionnée
Else
'copie des valeurs pour tableau si cle2 <> cle1
Cellule.Offset(, 2).Value = Matrice
Cellule.Offset(, 3).Value = X
Cellule.Offset(, 4).Value = uX
Cellule.Offset(, 5).Value = sX
Cellule.Offset(, 6).Value = ResultLabo
Cellule.Offset(, 7).Value = Circuit
Cellule.Offset(, 8).Value = Essai
Cellule.Offset(, 9).Value = Fabrication
'GoTo A
Cellule = .Range(Cellule.Offset(1, 0))
Exit For 'sortie boucle feuille selectionnée
End If
Else
'copie des valeurs pour tableau si cle2 est vide
Cellule.Offset(, 2).Value = Matrice
Cellule.Offset(, 3).Value = X
Cellule.Offset(, 4).Value = uX
Cellule.Offset(, 5).Value = sX
Cellule.Offset(, 6).Value = ResultLabo
Cellule.Offset(, 7).Value = Circuit
Cellule.Offset(, 8).Value = Essai
Cellule.Offset(, 9).Value = Fabrication
'GoTo A
Cellule = Cellule.Offset(1, 0)
Exit For 'sortie boucle feuille selectionnée
End If
Next Cellule
End With
A: End If
Next CelluleTrouve
End With
Application.EnableEvents = True
'activation mise à jour écran
Application.ScreenUpdating = True
'retrait protection
Sheets("Synthese").Protect
Sheets(WshA).Protect
End SubVoici le code d'activation du module qui est placé dans la feuille OTA55
Option Explicit
Dim WshA As Variant
Sub Worksheet_Activate()
Application.EnableEvents = True
'appel fonction remplir tableau
Call RemplirTabl("OTA55")
End SubEt voici mon fichier test qui est une simplification de mon fichier original sans les autres macros et feuilles:
Les lignes 4 et 6 de la feuille "Synthese" ne doivent pas être importées
Bonjour,
une proposition de correction de ton code
Option Explicit
Dim Compo As Variant 'variable de la cellule C9 de la page activée
Dim CelluleTrouve As Variant 'variable C9 à recherchée dans synthese
Dim Plage As Range 'plage de recherche dynamique
Dim Cle1 As Variant 'variable contenant concatenation synthese
Dim Matrice As String 'matrice
Dim X As Variant 'X des labos
Dim uX As Variant 'uX des labos
Dim sX As Variant 'sX des labos
Dim ResultLabo As Variant 'results labo
Dim Circuit As Variant 'circuit
Dim Essai As Variant 'essai
Dim Fabrication As Variant 'numero d'identification
Dim Cellule As Variant 'cellule actice dans la feuille activée
Dim Cle2 As Variant 'variable contenant concatenation selectionnée
Dim newcel As Range 'cellule qui doit recevoir la nouvelle clé
Dim trouvé As Boolean 'indique si cle existe déjà
Dim dl As Long ' ligne sur laquelle inscrire les nouvelles données
Public Sub RemplirTabl(WshA As Variant)
Application.EnableEvents = False
'activation mise à jour écran
Application.ScreenUpdating = False
'retrait protection
Sheets("Synthese").Unprotect
Sheets(WshA).Unprotect
'attribuer la valeur C9 de la feuille choisie
Compo = ""
Compo = ThisWorkbook.Sheets(WshA).Range("C9").Value
'Verification et remplissage du tableau de la feuille selectionnée
With Sheets("Synthese")
'mise à zero des 2 variables et definition de la plage de cellule
CelluleTrouve = ""
Cle1 = ""
Set Plage = ThisWorkbook.Sheets("Synthese").Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row)
'boucle sur la colonne F de la feuille synthese pour recherche de la valeur C9
For Each CelluleTrouve In Plage 'on parcourt les cellules de la plage
If CelluleTrouve = Compo Then 'si on trouve une ligne avec la compo recherchée
'si la valeur est trouvée
'definit les différentes valeurs à copier dans le tableau
Cle1 = CelluleTrouve.Offset(, 21).Value 'valeur de la concatenation matrice X uX sX Xlabo....
Matrice = CelluleTrouve.Offset(, -2).Value
X = CelluleTrouve.Offset(, 3).Value
uX = CelluleTrouve.Offset(, 4).Value
sX = CelluleTrouve.Offset(, 5).Value
ResultLabo = CelluleTrouve.Offset(, 16).Value
Circuit = CelluleTrouve.Offset(, -5).Value
Essai = CelluleTrouve.Offset(, -4).Value
Fabrication = CelluleTrouve.Offset(, -3).Value
'sur la feuille selectionnée
With Sheets(WshA)
'mise à zero des variables
trouvé = False
dl = 16 'première pour la recherche d'une clé existante
'boucle pour vérifier si la valeur cellule trouvée existe déjà
For Each Cellule In Sheets(WshA).Range("CQ16:CQ65")
If Cellule.Value = "" Then Exit For 'si ligne blanche , il n'y a plus de clé
If Cellule.Value = Cle1 Then trouvé = True: Exit For 'verifie si cle2 = cle1
dl = dl + 1
Next Cellule
If Not trouvé Then
'copie des valeurs pour tableau si on n'a pas trouvé clé1 dans la colonne CQ
Set newcel = Cells(dl, "cq") ' on se positionne sur la cellule qui va recevoir la nouvelle clé
newcel.Offset(, 2).Value = Matrice
newcel.Offset(, 3).Value = X
newcel.Offset(, 4).Value = uX
newcel.Offset(, 5).Value = sX
newcel.Offset(, 6).Value = ResultLabo
newcel.Offset(, 7).Value = Circuit
newcel.Offset(, 8).Value = Essai
newcel.Offset(, 9).Value = Fabrication
End If
End With
A: End If
Next CelluleTrouve
End With
Application.EnableEvents = True
'activation mise à jour écran
Application.ScreenUpdating = True
'retrait protection
Sheets("Synthese").Protect
Sheets(WshA).Protect
End Subd
Merci à toi h2so4 pour cette réponse plus que rapide. Et je crois que celle-ci résoudra mon problème
Je testerai la correction apportée demain car je n'ai pas de VM installée sur linux.
Je ferais le retex dès que les tests seront effectués.
d
Bonjour h2so4
Le code me semblait parfait à la première activation de la feuille "OTA55".
Mais si je réactive cette feuille une seconde fois, les lignes copiées au 1er passage se répétent ce qui me crée des doublons.
Je pense savoir d'où vient le problème, il faudrait que la macro vérifie si la cle1 (Synthese) existe déjà dans la feuille "OTA55" avant toute action. Mais je ne sais où l'intégrer dans la macro et comment l'écrire pour résoudre ce problème.
Voici ton code que j'ai gardé tel quel :
Option Explicit
Dim Compo As Variant 'variable de la cellule C9 de la page activée
Dim CelluleTrouve As Variant 'variable C9 à recherchée dans synthese
Dim Plage As Range 'plage de recherche dynamique
Dim Cle1 As Variant 'variable contenant concatenation synthese
Dim Matrice As String 'matrice
Dim X As Variant 'X des labos
Dim uX As Variant 'uX des labos
Dim sX As Variant 'sX des labos
Dim ResultLabo As Variant 'results labo
Dim Circuit As Variant 'circuit
Dim Essai As Variant 'essai
Dim Fabrication As Variant 'numero d'identification
Dim Cellule As Variant 'cellule actice dans la feuille activée
Dim Cle2 As Variant 'variable contenant concatenation selectionnée
Dim NewCel As Range 'cellule qui doit recevoir la nouvelle clé
Dim CellTrouve As Boolean 'indique si cle existe déjà
Dim DLign As Long 'ligne sur laquelle inscrire les nouvelles données
Public Sub RemplirTablo(WshA As Variant)
Application.EnableEvents = False
'activation mise à jour écran
Application.ScreenUpdating = False
'retrait protection
Sheets("Synthese").Unprotect
Sheets(WshA).Unprotect
'attribuer la valeur C9 de la feuille choisie
Compo = ""
Compo = ThisWorkbook.Sheets(WshA).Range("C9").Value
'Verification et remplissage du tableau de la feuille selectionnée
With Sheets("Synthese")
'mise à zero des 2 variables et definition de la plage de cellule
CelluleTrouve = ""
Cle1 = ""
'definition de la palge à balayer
Set Plage = ThisWorkbook.Sheets("Synthese").Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row)
'boucle sur la colonne F de la feuille synthese pour recherche de la valeur C9
For Each CelluleTrouve In Plage 'on parcourt les cellules de la plage
If CelluleTrouve.Value = "" Then Exit For 'si cellule vide sortie de la procédure
If CelluleTrouve.Value = Compo Then 'si on trouve une ligne avec la compo recherchée
'si la valeur est trouvée
'definit les différentes valeurs à copier dans le tableau
Cle1 = CelluleTrouve.Offset(, 21).Value 'valeur de la concatenation matrice X uX sX Xlabo....
Matrice = CelluleTrouve.Offset(, -2).Value
X = CelluleTrouve.Offset(, 3).Value
uX = CelluleTrouve.Offset(, 4).Value
sX = CelluleTrouve.Offset(, 5).Value
ResultLabo = CelluleTrouve.Offset(, 16).Value
Circuit = CelluleTrouve.Offset(, -5).Value
Essai = CelluleTrouve.Offset(, -4).Value
Fabrication = CelluleTrouve.Offset(, -3).Value
'sur la feuille selectionnée
With Sheets(WshA)
'mise à zero des variables
CellTrouve = False
DLign = 16 'première pour la recherche d'une clé existante
'boucle pour vérifier si la valeur cellule trouvée existe déjà
For Each Cellule In Sheets(WshA).Range("CQ16:CQ65")
'si cellule vide, pas de clé
If Cellule.Value = "" Then Exit For
'verifie si cle2 = cle1
If Cellule.Value = Cle1 Then CellTrouve = True: Exit For
DLign = DLign + 1
Next Cellule
'verifie état variable cellule trouvé pour la comparaison de la clé
If Not CellTrouve Then
'copie des valeurs pour tableau si on n'a pas trouvé clé1 dans la colonne CQ
Set NewCel = Cells(DLign, "CQ") ' on se positionne sur la cellule qui va recevoir la nouvelle clé
NewCel.Offset(, 2).Value = Matrice
NewCel.Offset(, 3).Value = X
NewCel.Offset(, 4).Value = uX
NewCel.Offset(, 5).Value = sX
NewCel.Offset(, 6).Value = ResultLabo
NewCel.Offset(, 7).Value = Circuit
NewCel.Offset(, 8).Value = Essai
NewCel.Offset(, 9).Value = Fabrication
End If
End With
End If
Next CelluleTrouve
End With
Application.EnableEvents = True
'activation mise à jour écran
Application.ScreenUpdating = True
'protection
Sheets("Synthese").Protect
Sheets(WshA).Protect
End SubMerci.
Bonjour,
proposition de correction
Option Explicit
Dim Compo As Variant 'variable de la cellule C9 de la page activée
Dim CelluleTrouve As Variant 'variable C9 à recherchée dans synthese
Dim Plage As Range 'plage de recherche dynamique
Dim Cle1 As Variant 'variable contenant concatenation synthese
Dim Matrice As String 'matrice
Dim X As Variant 'X des labos
Dim uX As Variant 'uX des labos
Dim sX As Variant 'sX des labos
Dim ResultLabo As Variant 'results labo
Dim Circuit As Variant 'circuit
Dim Essai As Variant 'essai
Dim Fabrication As Variant 'numero d'identification
Dim Cellule As Variant 'cellule actice dans la feuille activée
Dim Cle2 As Variant 'variable contenant concatenation selectionnée
Dim NewCel As Range 'cellule qui doit recevoir la nouvelle clé
Dim CellTrouve As Boolean 'indique si cle existe déjà
Dim DLign As Long 'ligne sur laquelle inscrire les nouvelles données
Public Sub RemplirTablo(WshA As Variant)
Application.EnableEvents = False
'activation mise à jour écran
Application.ScreenUpdating = False
'retrait protection
Sheets("Synthese").Unprotect
Sheets(WshA).Unprotect
'attribuer la valeur C9 de la feuille choisie
Compo = ""
Compo = ThisWorkbook.Sheets(WshA).Range("C9").Value
'Verification et remplissage du tableau de la feuille selectionnée
With Sheets("Synthese")
'mise à zero des 2 variables et definition de la plage de cellule
CelluleTrouve = ""
Cle1 = ""
'definition de la palge à balayer
Set Plage = ThisWorkbook.Sheets("Synthese").Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row)
'boucle sur la colonne F de la feuille synthese pour recherche de la valeur C9
For Each CelluleTrouve In Plage 'on parcourt les cellules de la plage
If CelluleTrouve.Value = "" Then Exit For 'si cellule vide sortie de la procédure
If CelluleTrouve.Value = Compo Then 'si on trouve une ligne avec la compo recherchée
'si la valeur est trouvée
'definit les différentes valeurs à copier dans le tableau
Cle1 = CelluleTrouve.Offset(, 21).Value 'valeur de la concatenation matrice X uX sX Xlabo....
Matrice = CelluleTrouve.Offset(, -2).Value
X = CelluleTrouve.Offset(, 3).Value
uX = CelluleTrouve.Offset(, 4).Value
sX = CelluleTrouve.Offset(, 5).Value
ResultLabo = CelluleTrouve.Offset(, 16).Value
Circuit = CelluleTrouve.Offset(, -5).Value
Essai = CelluleTrouve.Offset(, -4).Value
Fabrication = CelluleTrouve.Offset(, -3).Value
'sur la feuille selectionnée
With Sheets(WshA)
'mise à zero des variables
CellTrouve = False
'boucle pour vérifier si la valeur cellule trouvée existe déjà
For Each Cellule In Sheets(WshA).Range("Cr16:Cr65")
'si cellule vide, pas de clé
If Cellule.Value = "" Then Exit For
'verifie si cle2 = cle1
If Cellule.Value = Cle1 Then CellTrouve = True: Exit For
Next Cellule
'verifie état variable cellule trouvé pour la comparaison de la clé
If Not CellTrouve Then
DLign = .Cells(Rows.Count, "cr").End(xlUp).Row + 1 'première pour l'ajout d'une nouvelle clé
'copie des valeurs pour tableau si on n'a pas trouvé clé1 dans la colonne CQ
Set NewCel = Cells(DLign, "CQ") ' on se positionne sur la cellule qui va recevoir la nouvelle clé
NewCel.Offset(, 1).Value = Cle1
NewCel.Offset(, 2).Value = Matrice
NewCel.Offset(, 3).Value = X
NewCel.Offset(, 4).Value = uX
NewCel.Offset(, 5).Value = sX
NewCel.Offset(, 6).Value = ResultLabo
NewCel.Offset(, 7).Value = Circuit
NewCel.Offset(, 8).Value = Essai
NewCel.Offset(, 9).Value = Fabrication
End If
End With
End If
Next CelluleTrouve
End With
Application.EnableEvents = True
'activation mise à jour écran
Application.ScreenUpdating = True
'protection
Sheets("Synthese").Protect
Sheets(WshA).Protect
End Subd
Bonsoir h2so4;
Merci pour le code que je testerai demain.
De mon côté j'ai mis en place une autre solution sur le même principe mise en place dans le code reçu.
Voici le mien :
Option Explicit
Dim Compo As Variant 'variable de la cellule C9 de la page activée
Dim CelluleTrouve As Variant 'variable C9 à recherchée dans synthese
Dim Plage As Range 'plage de recherche dynamique
Dim Cle1 As Variant 'variable contenant concatenation synthese
Dim Matrice As String 'matrice
Dim X As Variant 'X des labos
Dim uX As Variant 'uX des labos
Dim sX As Variant 'sX des labos
Dim ResultLabo As Variant 'results labo
Dim Circuit As Variant 'circuit
Dim Essai As Variant 'essai
Dim Fabrication As Variant 'numero d'identification
Dim Cellule1 As Variant
Dim Cellule As Variant 'cellule actice dans la feuille activée
Dim Cle2 As Variant 'variable contenant concatenation selectionnée
Dim NewCel As Range 'cellule qui doit recevoir la nouvelle clé
Dim CellTrouve As Boolean 'indique si cle existe déjà
Dim DLign As Long 'ligne sur laquelle inscrire les nouvelles données
Public Sub RemplirTablo(WshA As Variant)
Application.EnableEvents = False
'activation mise à jour écran
Application.ScreenUpdating = False
'retrait protection
Sheets("Synthese").Unprotect
Sheets(WshA).Unprotect
'attribuer la valeur C9 de la feuille choisie
Compo = ""
Compo = ThisWorkbook.Sheets(WshA).Range("C9").Value
'Verification et remplissage du tableau de la feuille selectionnée
With Sheets("Synthese")
'mise à zero des 2 variables et definition de la plage de cellule
CelluleTrouve = ""
Cle1 = ""
'definition de la palge à balayer
Set Plage = ThisWorkbook.Sheets("Synthese").Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row)
'boucle sur la colonne F de la feuille synthese pour recherche de la valeur C9
For Each CelluleTrouve In Plage 'on parcourt les cellules de la plage
If CelluleTrouve.Value = "" Then Exit For 'si cellule vide sortie de la procédure
If CelluleTrouve.Value = Compo Then 'si on trouve une ligne avec la compo recherchée
'attribution de la concatenation à la variable cle1
Cle1 = CelluleTrouve.Offset(, 21).Value 'valeur de la concatenation matrice X uX sX Xlabo....
'sur la feuille selectionnée verification si la clé existe
With Sheets(WshA)
'boucle pour vérifier si la valeur cellule trouvée existe déjà
For Each Cellule1 In Sheets(WshA).Range("CQ16:CQ65")
If Cellule1.Value = "" Then GoTo A
'verifie si cle1 est dans la feuille activée
If Cellule1.Value = Cle1 Then GoTo B
A: Next Cellule1
End With
'definit les différentes valeurs à copier dans le tableau
Matrice = CelluleTrouve.Offset(, -2).Value
X = CelluleTrouve.Offset(, 3).Value
uX = CelluleTrouve.Offset(, 4).Value
sX = CelluleTrouve.Offset(, 5).Value
ResultLabo = CelluleTrouve.Offset(, 16).Value
Circuit = CelluleTrouve.Offset(, -5).Value
Essai = CelluleTrouve.Offset(, -4).Value
Fabrication = CelluleTrouve.Offset(, -3).Value
'sur la feuille selectionnée
With Sheets(WshA)
'mise à zero des variables
CellTrouve = False
DLign = 16 'première pour la recherche d'une clé existante
'boucle pour vérifier si la valeur cellule trouvée existe déjà
For Each Cellule In Sheets(WshA).Range("CQ16:CQ65")
'si cellule vide, pas de clé
If Cellule.Value = "" Then Exit For
'verifie si cle2 = cle1
If Cellule.Value = Cle1 Then CellTrouve = True: Exit For
DLign = DLign + 1
Next Cellule
'verifie état variable cellule trouvé pour la comparaison de la clé
If Not CellTrouve Then
'copie des valeurs pour tableau si on n'a pas trouvé clé1 dans la colonne CQ
Set NewCel = Cells(DLign, "CQ") ' on se positionne sur la cellule qui va recevoir la nouvelle clé
NewCel.Offset(, 2).Value = Matrice
NewCel.Offset(, 3).Value = X
NewCel.Offset(, 4).Value = uX
NewCel.Offset(, 5).Value = sX
NewCel.Offset(, 6).Value = ResultLabo
NewCel.Offset(, 7).Value = Circuit
NewCel.Offset(, 8).Value = Essai
NewCel.Offset(, 9).Value = Fabrication
End If
End With
B: End If
Next CelluleTrouve
End With
'ajustement colonne
ThisWorkbook.Sheets(WshA).Cells.EntireColumn.AutoFit
Application.EnableEvents = True
'activation mise à jour écran
Application.ScreenUpdating = True
'protection
Sheets("Synthese").Protect
Sheets(WshA).Protect
End SubJe l'ai testé et il fonctionne. Mais il faut que je vois celui qui sera plus rapide avant de passer en "RESOLU"
Merci.
d
Bonjour,
Après test, j'applique ce code
Option Explicit
Dim Compo As Variant 'variable de la cellule C9 de la page activée
Dim CelluleTrouve As Variant 'variable C9 à recherchée dans synthese
Dim Plage As Range 'plage de recherche dynamique
Dim Cle1 As Variant 'variable contenant concatenation synthese
Dim Matrice As String 'matrice
Dim X As Variant 'X des labos
Dim uX As Variant 'uX des labos
Dim sX As Variant 'sX des labos
Dim ResultLabo As Variant 'results labo
Dim Circuit As Variant 'circuit
Dim Essai As Variant 'essai
Dim Fabrication As Variant 'numero d'identification
Dim Cellule1 As Variant
Dim Cellule As Variant 'cellule actice dans la feuille activée
Dim Cle2 As Variant 'variable contenant concatenation selectionnée
Dim NewCel As Range 'cellule qui doit recevoir la nouvelle clé
Dim CellTrouve As Boolean 'indique si cle existe déjà
Dim DLign As Long 'ligne sur laquelle inscrire les nouvelles données
Public Sub RemplirTablo(WshA As Variant)
Application.EnableEvents = False
'activation mise à jour écran
Application.ScreenUpdating = False
'retrait protection
Sheets("Synthese").Unprotect
Sheets(WshA).Unprotect
'attribuer la valeur C9 de la feuille choisie
Compo = ""
Compo = ThisWorkbook.Sheets(WshA).Range("C9").Value
'Verification et remplissage du tableau de la feuille selectionnée
With Sheets("Synthese")
'mise à zero des 2 variables et definition de la plage de cellule
CelluleTrouve = ""
Cle1 = ""
'definition de la palge à balayer
Set Plage = ThisWorkbook.Sheets("Synthese").Range("F2:F" & Cells(Rows.Count, 1).End(xlUp).Row)
'boucle sur la colonne F de la feuille synthese pour recherche de la valeur C9
For Each CelluleTrouve In Plage 'on parcourt les cellules de la plage
If CelluleTrouve.Value = "" Then Exit For 'si cellule vide sortie de la procédure
If CelluleTrouve.Value = Compo Then 'si on trouve une ligne avec la compo recherchée
'attribution de la concatenation à la variable cle1
Cle1 = CelluleTrouve.Offset(, 21).Value 'valeur de la concatenation matrice X uX sX Xlabo....
'sur la feuille selectionnée verification si la clé existe
With Sheets(WshA)
'boucle pour vérifier si la valeur cellule trouvée existe déjà
For Each Cellule1 In Sheets(WshA).Range("CQ16:CQ65")
If Cellule1.Value = "" Then GoTo A
'verifie si cle1 est dans la feuille activée
If Cellule1.Value = Cle1 Then GoTo B
A: Next Cellule1
End With
'definit les différentes valeurs à copier dans le tableau
Matrice = CelluleTrouve.Offset(, -2).Value
X = CelluleTrouve.Offset(, 3).Value
uX = CelluleTrouve.Offset(, 4).Value
sX = CelluleTrouve.Offset(, 5).Value
ResultLabo = CelluleTrouve.Offset(, 16).Value
Circuit = CelluleTrouve.Offset(, -5).Value
Essai = CelluleTrouve.Offset(, -4).Value
Fabrication = CelluleTrouve.Offset(, -3).Value
'sur la feuille selectionnée
With Sheets(WshA)
'mise à zero des variables
CellTrouve = False
DLign = 16 'première pour la recherche d'une clé existante
'boucle pour vérifier si la valeur cellule trouvée existe déjà
For Each Cellule In Sheets(WshA).Range("CQ16:CQ65")
'si cellule vide, pas de clé
If Cellule.Value = "" Then Exit For
'verifie si cle2 = cle1
If Cellule.Value = Cle1 Then CellTrouve = True: Exit For
DLign = DLign + 1
Next Cellule
'verifie état variable cellule trouvé pour la comparaison de la clé
If Not CellTrouve Then
'copie des valeurs pour tableau si on n'a pas trouvé clé1 dans la colonne CQ
Set NewCel = Cells(DLign, "CQ") ' on se positionne sur la cellule qui va recevoir la nouvelle clé
NewCel.Offset(, 2).Value = Matrice
NewCel.Offset(, 3).Value = X
NewCel.Offset(, 4).Value = uX
NewCel.Offset(, 5).Value = sX
NewCel.Offset(, 6).Value = ResultLabo
NewCel.Offset(, 7).Value = Circuit
NewCel.Offset(, 8).Value = Essai
NewCel.Offset(, 9).Value = Fabrication
End If
End With
B: End If
Next CelluleTrouve
End With
'ajustement colonne
ThisWorkbook.Sheets(WshA).Cells.EntireColumn.AutoFit
Application.EnableEvents = True
'activation mise à jour écran
Application.ScreenUpdating = True
'protection
Sheets("Synthese").Protect
Sheets(WshA).Protect
End SubEn effet il m'évite la création d'une colonne supplémentaire pour la vérification de l'existence de la clé de la feuille "SYNTHESE" dans la feuille "OTA55".
Mon problème est résolu.
Merci pour ce coup de main plus qu'appréciable.