Recherche sur partie de mot puis copier coller décalé

joel31

XLDnaute Junior
Bonjour le forum,

je reviens vers vous, car ce site apporte toujours d'excellentes réponses au béotien que je suis.:rolleyes:

J'ai un problème qui me semblait relativement simple, je tourne autour, mais n'arrive pas à trouver la bonne solution.

Comme le montre le petit fichier ci-joint, je souhaite, quand j'entre une valeur dans une cellule de ma colonne A, si ce mot commence par VAC, (exemple VACANCE, VACANCES, VACANCES ZONE etc..) il me le copie sur la même ligne trois colonnes plus loin en D.
Je ne peux pas utiliser de formules en D, car je peux avoir d'autres valeurs que VAC etc.. dans ma colonne A et que ça me les recopierait.
J'ai besoin donc d'une macro qui me fasse cette recherche puis copie et colle.
Mon fichier comprend une macro "test" qui fonctionne que lorsque la première occurrence est trouvée, mais pas à chaque nouvelle entrée.
Un peu d'aide serait bienvenue, car je rame dessus depuis hier.
Merci pour votre lecture et l'aide que vous pourrez m'apporter.
Bien cordialement
Joël
 

Fichiers joints

pedrag31

XLDnaute Occasionnel
Re : Recherche sur partie de mot puis copier coller décalé

Bonjour Joel31, Bonjour le forum,

Bienvenue sur XLD! :D

Ci-joint, une proposition avec une macro évènementielle sur Worksheet_Change qui fait que la copie "VACANCES" ou "TRAVAIL" se fait lorsque la valeur de la cellule change. Cela évite de re parcourir toutes les cellules de la feuille avec Find.

Si tu veux faire une recherche sur toute ta colonne avec Find pour traiter un tableau existant, il vaudrait mieux éviter de l'attacher à une macro évènementielle qui, pour chaque changement de cellule, va refaire le travail sur toute la feuille. Si toutefois, tu veux absolument passer par Find, tu peux poster de nouveau et on regardera ce qui est faisable.

VB:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)

'ici on teste si la cellule qui a changé est dans la colonne 1 (A) et que sa valeur est non nulle
If Target.Column = 1 And Target.Value <> "" Then

    'ici on teste maintenant de quelle nature est la valeur et s'il faut copier
    Select Case True
    
    Case Target.Value Like "*VAC*"
        Target.Offset(0, 3).Value = "VACANCES"
        
    Case Target.Value Like "*TRAV*"
        Target.Offset(0, 3).Value = "TRAVAIL"
        
    'si aucun des cas précedents n'est vrai
    Case Else
        Target.Offset(0, 3).Value = "Catégorie Inconnue"
        
    End Select

End If

End Sub
Bonne journée :)
 

Fichiers joints

Dernière édition:

joel31

XLDnaute Junior
Re : Recherche sur partie de mot puis copier coller décalé

Bonjour Pedrag31,

Merci pour ta réponse rapide, un dimanche en plus !

Ta solution est la bonne, à savoir que l'action est lancée si un mot commençant par VAC est entré dans la colonne A.

Toutefois, ce que je souhaite, c'est que la valeur de la cellule en A soit recopiée en D.
Ta solution me recopie systématiquement VACANCE ou TRAVAIL.
Exemple si j'entre VACANCES ZONE A B C, cela me le recopie en D
Si j'entre VACANCE , cela me le recopie en D etc..

On n'est plus très loin !

Merci encore de te pencher sur ce cas.

Bien cordialement

Joël
 

joel31

XLDnaute Junior
Re : Recherche sur partie de mot puis copier coller décalé

Re bonjour Pedrag31,

En fait, j'ai posté avant de chercher :mad:

Mais en cherchant j'ai trouvé :(

Case Target.Value Like "*VAC*"
Target.Offset(0, 3).Value = Target.Value

Il fallait modifier le ="VACANCE" par = Target.value

Super, merci encore pour m'avoir montré le chemin.

Bien cordialement

Joël
 

joel31

XLDnaute Junior
Re : Recherche sur partie de mot puis copier coller décalé

Bon ben décidément !

Ca fonctionne très bien sur mon fichier test, mais voilà, je dois incorporer tout ça dans mon fichier final, dans lequel j'ai déjà un worksheet change, cf ci-dessous.

Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim s As Object, n%
Dim Cellule As Range, Nombre As Integer, Adresse As String, Plage As Range
If Not Application.Intersect(Target, Range("A4")) Is Nothing Then
Call CopierDate
End If
If [ETB] <> 0 Then
Ve
Else
If [ETBA] <> 0 Then
Ve1
End If
End If
If Not Intersect(Target, Range("BA4:BB80")) Is Nothing Then
Tri
reunion
Retrier
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each s In Sheets
n = Val(s.Name)
If Application.CountIf([BC:BC], s.Name) = 0 Then s.Delete
Next
End If
With Target
If Intersect(Target, Range("B:C,G:H,L:M,Q:R,V:W,AA:AB,AF:AG,AK:AL,AP:AQ")) Is Nothing Or .Text = "" Or .Count > 1 Then Exit Sub
Adresse = "B" & .Row - Weekday(Range("A" & .Row)) + 1 & ":W" & .Row - Weekday(Range("A" & .Row)) + 7
Set Plage = Intersect(Range(Adresse), Range("B:C,G:H,L:M,Q:R,V:W,AA:AB,AF:AG,AK:AL,AP:AQ"))
For Each Cellule In Plage
If Cellule = Target And Cellule.Column <> Target.Column Then
MsgBox "Il existe déjà une formation cette semaine pour cet établissement !", vbCritical + vbOKOnly, "ATTENTION !"
.ClearContents
Exit Sub
End If
Next Cellule
End With

Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub


Donc, où devrais-je insérer la nouvelle macro pour que ça fonctionne ?:rolleyes:

Bien cordialement

Joël
 

pedrag31

XLDnaute Occasionnel
Re : Recherche sur partie de mot puis copier coller décalé

Re,

Il fallait modifier le ="VACANCE" par = Target.value
Super, ça fait plaisir de voir que tu as trouvé immédiatement. C'est que tu comprends bien comment le code fonctionne. :cool:

Pour ce qui est d'intégrer ta macro dans le code existant, je te propose une tentative ci-dessous.
Fais quand même une sauvegarde de ton fichier et teste tout ça sur une copie, on sait jamais, comme je n'ai pas ton fichier de travail pour comprendre, il se pourrait que ça fasse des choses bizarres...

Là, comme ça, sans voir le fichier, il semblerait que ce soit un peu une "usine à gaz" (pas d'offense :rolleyes:).
Je me demande par exemple si, parfois, le fichier ne mouline pas longtemps (appel de bcp de macros sur un même évènement) quand on y fait des modifs importantes (copie/colle une ligne par exple)... Il y a surement de l'optimisation de possible si tu veux t'y lancer...

VB:
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim s As Object, n%
Dim Cellule As Range, Nombre As Integer, Adresse As String, Plage As Range

'teste si la cellule modifiée est A4 et appelle la macro CopierDate
If Not Application.Intersect(Target, Range("A4")) Is Nothing Then
    Call CopierDate
End If

'Je pense qu'on peut ajouter ta macro ici...
'Fais une sauvegarde de ton fichier et teste sur une copie, on sait jamais, comme je n'ai pas ton fichier il se pourrait que ça fasse des choses bizarres...
'*********************************************************
'ici on teste si la cellule qui a changé est dans la colonne 1 (A) et que sa valeur est non nulle
If Target.Column = 1 And Target.Value <> "" Then

    'ici on teste maintenant de quelle nature est la valeur et s'il faut copier
   Select Case True
   
    Case Target.Value Like "*VAC*"
        Target.Offset(0, 3).Value = Target.Value
       
    Case Target.Value Like "*TRAV*"
        Target.Offset(0, 3).Value = Target.Value
       
    'si aucun des cas précedents n'est vrai
   Case Else
        Target.Offset(0, 3).Value = "Catégorie Inconnue"
       
    End Select

End If
'*********************************************************

'teste si le range [ETB] est nul et appelle la macro Ve
If [ETB] <> 0 Then
        Ve
    Else
        If [ETBA] <> 0 Then
            Ve1
        End If
End If

'teste si la cellule modifiée est dans BA4:BB80 et appelle la macro Tri, puis reunion puis retrier
If Not Intersect(Target, Range("BA4:BB80")) Is Nothing Then
    Tri
    reunion
    Retrier
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    'boucle sur toute les feuilles
    For Each s In Sheets
        n = Val(s.Name)
        'supprime la feuille si elle n'apparait pas dans colonne BC ??? pas sur qd même là...
        If Application.CountIf([BC:BC], s.Name) = 0 Then s.Delete
    Next
End If

With Target
    'là ça a l'air d'être très spécifique à l'utilisation du classeur, je ne m'aventure pas à commenter car il faudrait le fichier pour comprendre
    If Intersect(Target, Range("B:C,G:H,L:M,Q:R,V:W,AA:AB,AF:AG,AK:AL,AP:AQ ")) Is Nothing Or .Text = "" Or .Count > 1 Then Exit Sub
    Adresse = "B" & .Row - Weekday(Range("A" & .Row)) + 1 & ":W" & .Row - Weekday(Range("A" & .Row)) + 7
    Set Plage = Intersect(Range(Adresse), Range("B:C,G:H,L:M,Q:R,V:W,AA:AB,AF:AG,AK:AL,AP:AQ "))
    For Each Cellule In Plage
        If Cellule = Target And Cellule.Column <> Target.Column Then
            MsgBox "Il existe déjà une formation cette semaine pour cet établissement !", vbCritical + vbOKOnly, "ATTENTION !"
            .ClearContents
            Exit Sub
        End If
    Next Cellule
End With

'rafraichissement de l'affichage
Application.ScreenUpdating = True
'autorisation de l'affichage de messages Excel (erreurs, etc...)
Application.DisplayAlerts = True
End Sub
Bonne journée :)
 

joel31

XLDnaute Junior
Re : Recherche sur partie de mot puis copier coller décalé

Merci bien Pedrag31,

C'est exactement là qu'il fallait insérer le code.
Ça fonctionne impeccablement.;)

Je suis conscient que le code généré est une usine à gaz et que 'on pourrait l'améliorer, mais il a le mérite de bien fonctionner, et rapidement en plus, donc, pas d'urgence pour moi à le modifier.

Je pense quand même, qu'il ferait peur à un puriste comme Hasco et Job75 qui m'ont bien aidé par le passé.

Un grand salut à eux .

Merci également pour ton aide précieuse.

Bien cordialement

Joël
 

pedrag31

XLDnaute Occasionnel
Re : Recherche sur partie de mot puis copier coller décalé

Re,

C'est exactement là qu'il fallait insérer le code.
Ça fonctionne impeccablement.
Super! Faut aussi compter sur un peu de chance...

...il a le mérite de bien fonctionner, et rapidement en plus...
Au temps pour moi, oublie ma remarque si ça fonctionne bien, je faisais des hypothèses sans savoir. Tant que ça fait le boulot vite, l'optimisation peut bien attendre!

...un puriste comme Hasco et Job75...
J'ai beaucoup appris d'eux également et des conseils précieux qu'ils donnent dans leurs innombrables posts!
Ils sont en effet parmi les piliers d'XLD, de véritables Barbatruc du VBA!

Bonne soirée :)
 

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas