XL 2013 [RESOLU] Code VBA - Copie valeurs

[darkjedi]

Bonjour à tous,

Je me tourne vers vous car je rencontre un problème que je n'ai pas réussi à résoudre.
Je joins en PJ un fichier simplifié

Petit descriptif du fichier

Voici ce qui fonctionne:
J'ai un onglet "DONNEES-RESULTATS" qui reprend l'ensemble de mes données.
J'ai un onglet "C13" et "O18" où je renseigne chaque colonne.
En utilisant scripting dictionnary:
- si le numero échantillon existe dans la colonne A de l'onglet "DONNEES - RESULTATS" quand je tape ce numero dans la colonne A de l'onglet "C13", rien n'est créé.
- si le numero échantillon n'existe pas dans la colonne A de l'onglet "DONNEES - RESULTATS" quand je tape ce numero dans la colonne A de l'onglet "C13", celui-ci est créé dans la première cellule vide dans la colonne A de l'onglet "DONNEES - RESULTATS".

Descriptif du problème

Voici ce que j'aimerai en ayant rempli la colonne type :
- si le numero échantillon existe dans la colonne A de l'onglet "DONNEES - RESULTATS" quand je tape ce numero dans la colonne A de l'onglet "C13", il faudrait une vérification du type:
- Si identique ne rien faire
- Si different proposer un choix entre la valeur type de l'onglet "DONNEES - RESULTATS" et l'onglet "C13"

- si le numero échantillon n'existe pas dans la colonne A de l'onglet "DONNEES - RESULTATS" quand je tape ce numero dans la colonne A de l'onglet "C13", celui-ci est créé dans la première cellule vide dans la colonne A de l'onglet "DONNEES - RESULTATS" ainsi que la copie du type.


J'espère que mes explications sont comprehensibles.

Merci pour votre aide.

 

[darkjedi]

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

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 pa
            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

 

[Staple1600]

Bonsoir le fil

Question posée en novembre 2012
Editée en février 2021
Avec un feedback du demandeur dans la foulée de l'édition.
Je dis : double 😱
😉

dark jedi
Tu es resté bloqué 8 ans derrière le côté obscur de la Force ?
Et c'est n'est en qu'en 2021 , que tu as retrouvé la lumière ?
😉

 

[darkjedi]

Bonjour,

Heureusement non..... mais j'avais oublié de clôturer la discussion de novembre 2012 et je ne voulais pas attendre novembre 2021 😉....
Et c'est chose faite 😎

Cordialement,

darkjedi