Pb recopie donnee bdd sur feuilles a la fermeture
Bonjour à tous. Je rencontre un problème dans un fichier en cours de création. Je n'arrive pas à trouver la solution.
Voici le problème:
j'ai un fichier composé de plusieurs feuilles.
- BD est la feuille globale (tous les résultats y sont inscrits).
- C13 est la feuille des résultat C13.
- TQ est la feuilles des résultats TQ.
Chaque feuille de résultat est composé comme suit:
colonne A : identification.
colonne B: résultat.
colonne C: type.
La feuille BD est composée:
colonne A: identification.
colonne B: n°entrée.
colonne C: type.
colonne D: resultat TQ.
colonne E : resultat C13.
Dans la feuille TQ je remplis les 3 colonnes comme suit:
A B C
2000 12.0 Toto
Valeur existante avant saisie dans TQ
C13:
A B C
2000 1.0 Popo
BD
A B C D E
2000 Popo #NA 1.0
Si la donnée existe sur BD c'est qu'elle existe sur C3 avec la colonne type = popo.
Donc nous ferons un choix entre le type TQ (Toto) et le type BD /C13 (popo) par le biais d'une MsgBox.
Si nous voulons que le type change (passage de popo (C13) à toto (TQ)) pas de probleme sur la feuille BD.
Donc voici les feuilles après validation de la msgbox
TQ:
A B C
2000 12.0 Toto
BD
A B C D E
2000 Toto 12.0 1.0
C13:
A B C
2000 1.0 Popo
J'aimerais qu'à la fermeture de mon fichier que le type défini sur la feuille BD soit répercuté dans les feuille C13 (changement popo en toto) et TQ (pas de changement).
J'ai essayer d'utiliser le dictionnaire mais cela ne fonctionne pas. Quellle peut-être la solution à ce problème?
NB:
Sur les feuilles C13 et TQ j'ai interdit la seélection d'une plage de cellule dans la conne A et C. Si cela est fait ouverture msgbox pour signaler le probléme mais je n'ai pas réussi à supprimer les valeurs saisies par incrémentation mise à part la première cellule.
Quelle est la technique?
Voici un fichier simplifié:
Merci pour toute aide.
Je me demandais s'il ne fallait pas utiliser 1 dico pour la feuille BD et un autre dico pour la feuille active.
suis-je sur la bonne voie?
Voici le code en fonction qui m'a permis de régler ce problème
Option Explicit
Dim k As Variant
Dim Ligne As Integer
Dim L As Variant
Dim LigSaisie As Variant
Dim adrSaisie As Variant
Dim Cel As Range
Dim F1 As Worksheet
Dim Lign As Long
Dim OldType As Variant
Dim plage As Range
Private Sub Worksheet_Change(ByVal Target As Range)
'**************************************************************************************************************
'**************************************************************************************************************
'VERIFICATION DOUBLONS
'**************************************************************************************************************
'**************************************************************************************************************
If Target.Column = 1 And Target.Row > 2 And Target.Count = 1 Then
LigSaisie = Target.Row
For L = 2 To Application.CountA([A:A])
If Cells(L, 1) = Cells(LigSaisie, 1) And L <> LigSaisie Then
MsgBox "Doublon avec ligne " & L
Application.EnableEvents = False
Application.Undo
Cells(LigSaisie, 1).Resize(, 39).ClearContents
Application.EnableEvents = True
End If
Next L
End If
'*************************************************************************************************************
'*************************************************************************************************************
'VERIFICATION RECOPIE TYPE SELON N°ECHANTILLON
'*************************************************************************************************************
'*************************************************************************************************************
Set F1 = Sheets("DONNEES - RESULTATS")
If Target.Count > 1 Then Exit Sub
If Target = "" Then Exit Sub
With Sheets("C13")
'Vérifie si une modif en colonne C
If Not Intersect(Range("C2:C" & Rows.Count), Target) Is Nothing Then
'Arrêt des événements
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
F1.Unprotect
If Range("A" & Target.Row) <> "" Then 'Un numéro d'échantillon
'recherche dans la 1ère page
Set Cel = F1.Columns("A").Find(what:=Range("A" & Target.Row), LookIn:=xlValues, lookat:=xlWhole)
If Not Cel Is Nothing Then 'On l'a trouvé
OldType = Cel.Offset(0, 2)
If OldType = "" Then OldType = "(Aucune valeur) "
If OldType <> Target Then
'Pose la question du remplacement
If MsgBox("Le précédent type défini pour l'échantillon " & Range("A" & Target.Row) & " est égal à " & vbCr & vbCr & vbTab & vbTab & OldType & vbCr & vbCr & _
" Voulez vous remplacer celui-ci ?" & vbCr & vbCr & vbTab & vbTab & Target, vbQuestion + vbYesNo, "Nouvelle valeur ") = vbYes Then
' Réponse on le remplace
Cel.Offset(0, 2) = Target
Else
' Réponse on le modifie
Target = Cel.Offset(0, 2)
End If
End If
Else
' Le numéro d'échantillon n'existe pas
Lign = F1.Range("A" & Rows.Count).End(xlUp).Row + 1
F1.Range("A" & Lign) = Range("A" & Target.Row)
F1.Range("C" & Lign) = Target
End If
Else
' Pas de numéro d'échantillon
Target = ""
MsgBox "Veuillez d'abord saisir un numéro d'échantillon"
End If
Application.EnableEvents = True ' Réactive les événements
F1.Protect
End If
End With
'***********************************************************************************************************
'***********************************************************************************************************
'VERIFICATION FORMAT NUMERO ECHANTILLON
'***********************************************************************************************************
'***********************************************************************************************************
Set k = Sheets("C13")
Ligne = Range("A65536").End(xlUp).Row
'permet de sortir de la procédure si plus d'une cellule est sélectionnée
'(sinon la suite de la macro renvoie un message d'erreur)
If Target.Count = 1 Then
On Error GoTo GESTERR
Application.ScreenUpdating = False 'désactive maj ecran
If Not Application.Intersect(Target, Cells(Ligne, 1)) Is Nothing Then
If Target <> "" Then
For Each Target In Range(k.[A2], k.[A65536].End(xlUp))
Application.EnableEvents = False 'désactive les événements
If Target.Value <> "" Then
Call Verif_Format(Target.Value)
If Verif_Format(Target.Value) = False Then
MsgBox ("Veuillez corriger le format d'identification de l'échantillon." & vbNewLine & "Formats possibles: ####-#### (#) / T##[A-Z) / ####-#### [A-Z].")
Target = ""
Target.Select
End If
End If
Application.EnableEvents = True 'réactive les événements
Next Target
End If
End If
Application.ScreenUpdating = True 'reactive maj ecran
End If
'rétabli le fonctionnement d'Excel avant de quitter
GESTERR:
Application.EnableEvents = True
Exit Sub
End Sub
'******************************************************************************************************
'******************************************************************************************************
'EVITER SELECTION MULTIPLE DANS COLONNE 1 ET 3
'******************************************************************************************************
'******************************************************************************************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Column = 3 And Target.Cells.Count > 2 Then
MsgBox "Il est interdit de sélectionner plusieurs cellules dans cette colonne."
Target.Cells(2, 1).Select
Set plage = Range(Target(2, 1), Target.End(xlDown))
plage.ClearContents
Target.Cells(2, 1).Select
End If
'
'If Target.Column = 1 And Target.Cells.Count > 1 Then
'MsgBox "Il est interdit de sélectionner plusieurs cellules dans cette colonne."
'Target.Cells(1, 1).Select
'Set plage = Range(Target(2, 1), Target.End(xlDown))
'plage.ClearContents
'Target.Cells(2, 1).Select
'End If
'**********************************************
'Redémarer compteur si activité sur la feuille
'**********************************************
Relancer
End Sub