Discussion :

[Djromé]

Bonjour les Kracks,

La macro ci-dessous me permet à chaque changement de cellule de la colonne C (dans une feuille donnée "fonction Worksheet_Change"), d'aller vérifier dans une autre feuille si le chiffre inscrit s'y trouve également et si oui, d'appliquer une condition.
Cette application fonctionne mais j'ai remarqué que lorsque dans cette onglet je sélectionne une ligne complète et j'essaie de la supprimer, sa bug!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
Option Explicit
 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
'Chase a number with special conditions in other sheet
 
Dim Accrng As Range
 
 
If Not Intersect(Target, Columns(3)) Is Nothing Then
'si la cellule modifiée appartient à la colonne 3 (C), alors
    Set Accrng = Target
    'fixer la variable Accrng
  Accrng.Offset(0, 2).FormulaR1C1 = "=VLOOKUP(RC[-2],Specialfees!C[-4]:C[4],4,FALSE)'??????? check why when we selected all ligne is bug"
        'La formule de la colonne E devient : C6 modifiée =>
    'E6 : "=RECHERCHEV(C6;Specialfees!A:K;4;0)" => Valeur de D de la ligne contenant C6 en A
    If IsError(Accrng.Offset(0, 2)) Then    'Si on ne trouve pas de valeur, alors
        Accrng.Offset(0, 2).ClearContents   'On efface E6
        Accrng.Offset(0, 1).Select          'On selectionne E6, prochaine cellule à encoder pour l'utilisateur
    Else 'Sinon
        Accrng.Offset(0, 2).Copy            'on copie la valeur donnée par le vlookup
        Accrng.Offset(0, 2).PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
       'on colle uniquement la valeur afin qu'il n'y ai plus de trace du vlookup nous permettant ainsi de retrouver la valeur dans le fichier par une fonction recherche Ctrl*f
        ActiveSheet.Paste
        Application.CutCopyMode = False
        Accrng.Offset(0, 1).Select
        'On selectionne D6, prochaine cellule à encoder pour l'utilisateur
   End If
 End If
End Sub

Le message d'erreur est le suivant:

Msg d'erreur:

Accrng.Offset(0,2).FormulaR1C1=<Application-defined or object-defined error>

[pgz]

Bonjour.

Dans la procédure, en début, tu peux ajouter

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

If Target.Columns.Count>1 then exit sub

Cela devrait éviter d'exécuter la procédure en cas d'effacement d'une ligne.

Cordialement,

PGZ

[Djromé]

Salut Pgz,

Bon subterfuge, celà fonctionne très bien!

Merci

[mercatog]

Tu peux simplifier comme ceci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim c As Range
 
Application.ScreenUpdating = False
If Not Intersect(Target, Columns(3)) Is Nothing Then
    If Target.Count = 1 Then
        Set c = Sheets("Specialfees").Range("E:E").Find(Target.Value, lookat:=xlWhole)
        Application.EnableEvents = False
        If c Is Nothing Then
            Target.Offset(0, 2).ClearContents
        Else
            Target.Offset(0, 2).Value = c.Offset(0, 2).Value
            Set c = Nothing
        End If
        Application.EnableEvents = True
        Target.Offset(0, 1).Select
    End If
End If
End Sub

[Djromé]

Salut Mercatog,

Effectivement, c'est plus fluide!

Merci

[mercatog]

Et en plus, tu bloque l'évènement Change quand la macro change Target.offset(0,2) à l'aide de

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Application.EnableEvents = False
'code qui écrit dans la feuille
Application.EnableEvents = True

une autre correction de l'orthographe: дурака учить, что мертвого лечить