Détecter un mot dans chaque ligne de cellule.

[Pexcel]

Bonjour,
je dois nettoyer une base que j'ai récupéré assez importante et je voudrais détecter le mot Badminton dans la ligne d'une cellule si le mot est présent laisser cette ligne dans cette même cellule et transférer les autres lignes si le mot n y est pas, dans une autre cellule, chaque ligne à un renvoie chariot. // puis passer dans la suivante ...
Voici l'exemple:
13/04/2017 : Initiation Badminton classe CE2
01/03/2018: Match handball CE1 vs Ce2
06/05/2018: tournoi Badminton Cm1/Cm2
27/05/2018: Initiation foot de salle CP
etc ...

Mon début de code

Sub netsports()
Application.ScreenUpdating = False
    Dim Plage As Range
    Dim Cels As Range

    With Worksheets("sports")
 
   Set Plage = .Range(.Cells(2, 29), .Cells(.Rows.Count, 29).End(xlUp))

    End With
    

   For Each Cels In Plage

If Cels.Offset(0, 9) Like "*Badminton*" Then

' ici boucle ligne par ligne dans la cellule en cours
' Si ligne contient pas Badminton on la transfère sur  Cels.Offset(0, 8)
'
'
'



Else

' pas de mot badminton on transfère tout sur cellule 8

  Dim phrase
  
phrase = Cels.Offset(0, 9).Value

With Cels.Offset(0, 8)



.Value = phrase & vbCrLf & .Value

 End With



End If 
  Next Cels


Application.ScreenUpdating = True
End Sub

Merci d'avance, prenez soin de vous et de vos proches ...

 

[zebanx]

Bonjour Pexcel, le forum

D'une manière différente, sur un UDF (VBA) communiqué hier par sousou sur le fil suivant

XL 2016 - Recherche dans une plage à partir d'une liste de mots

Bonjour Vu que je patauge un petit peu je vous demande de l'aide pour un projet largement simplifié ici. Je souhaite à l'aide de formules prioritairement (à défaut en VBA), rechercher en colonne B les "Opérations effectuées" contenant un défaut (mots) listé dans le tableau "Liste Défaut". Et...

www.excel-downloads.com

Et d'autres contributeurs ont fourni leurs solutions par formule qui, pour 2000 lignes, ne doit pas être long.
L'avantage c'est qu'on a plusieurs mots clés. Après, il ne reste plus qu'à tirer et filtrer.

xl-ment
zebanx

 

[BOISGONTIER]

Bonjour,


S'il faut tester 10.000 lignes, avec cette macro,le temps est 0,3 s , avec la fonction perso MCX() 4 sec.

Sub essai()
  Application.ScreenUpdating = False
  Set d = CreateObject("scripting.dictionary")
  For Each c In [ListeMots]
    d(c.Value) = ""
  Next c
  Set Rng = Range("A2:A" & [A65000].End(xlUp).Row)
  Rng.Offset(, 1).ClearContents
  Tbl = Rng.Value
  For i = 1 To UBound(Tbl)
      a = Split(Tbl(i, 1), " ")
      témoin = False
      For Each k In a
        If d.exists(k) Then témoin = True
      Next k
      If témoin Then Rng.Offset(, 1).Cells(i, 1) = "X"
  Next i
End Sub

Boisgontier

Boisgontier

 

[zebanx]

Bonjour JB

Merci déjà pour ta réponse et de ce code court et efficace, comme toujours.
Le problème avec l'utilisation du dictionnaire reste que contrairement à INSTR(), la recherche semble stricte.
De sorte que "tordue" ou "tordus" ne sont pas reconnus si le mot dans la liste est "tordu".
Je vais chercher...

Bonne journée à toi, xl-ment
zebanx

edit
Un essai mais ça mérite mieux surement

Sub motclé_sd2()
  '-- fait par jb
  T = Timer()
  Application.ScreenUpdating = False
  Set D = CreateObject("scripting.dictionary")
  '--tableau non nommé / version jb
  derl = Cells(Rows.Count, 5).End(3).Row
  For Each C In Range("E2:E" & derl)
    D(LCase(C.Value)) = "" '-- prise en compte lower case
  Next C
  Set Rng = Range("A2:A" & [A65000].End(xlUp).Row)
  Rng.Offset(, 2).ClearContents
  Tbl = Rng.Value
  For i = 1 To UBound(Tbl)
      A = Split(Tbl(i, 1), " ")
      témoin = False
      For Each k In A
         If Len(k) >= 2 Then
         k2 = Mid(k, 1, Len(k) - 1)  '-- contournement pluriel et féminin
         If D.exists(LCase(k)) Then témoin = True
         If D.exists(LCase(k2)) Then témoin = True
         End If
        Next k
      If témoin Then Rng.Offset(, 2).Cells(i, 1) = "X"
  Next i
  MsgBox Timer - T
End Sub

 

[job75]

Bonjour Pexcel, zebanx, JB,

zebanx et JB je ne comprends pas, au post #1 on ne parle pas de "X" mais de renvois à la ligne...

A+

 

[job75]

Fichier joint avec ce que j'ai compris :

Sub Traiter()
Dim txt$, tablo, i&, s, x$, y$, j%
txt = "Badminton" 'à adapter
With [A1].CurrentRegion.Resize(, 3)
    tablo = .Value 'matrice, plus rapide
    For i = 2 To UBound(tablo)
        s = Split(tablo(i, 1), vbLf)
        x = "": y = ""
        For j = 0 To UBound(s)
            If InStr(s(j), txt) Then x = x & vbLf & s(j) Else y = y & vbLf & s(j)
        Next j
        tablo(i, 2) = IIf(x = "", "", Mid(x, 2))
        tablo(i, 3) = IIf(y = "", "", Mid(y, 2))
    Next i
    .Value = tablo 'restitution
End With
End Sub

J'ai copié A2 sur 60 000 lignes, la macro s'exécute chez moi en 1,7 seconde.

 

[jmfmarques]

Bonjour job75
Tu gagnerais encore un peu de temps en remplaçant tes deux fonctions IIF par deux instructions If ... then ... else (moins "confortables" mais beaucoup plus rapides)
(j'ai eu très récemment l'occasion d'exposer pourquoi).

 

[zebanx]

Bonjour Job75, jfmarques

@job75
Tu as raison... l'empressement avec la non transmission d'un fichier excel (ma mauvaise fois récurrente à la transmission de 0 fichier et d'une réactivité appréciable à un post).
Mes excuses à JB pour l'avoir induit en erreur sur la restitution du coup.

Un autre code avec instr() et l'utilisation de cells avec un array (2 mots cherchés ici) et split.
Moins rapide et efficace incontestablement.

Merci pour ton code efficace et conclusif.
Bon apm à toi
zebanx

Sub shextract_2mc()
'-- extraction avec 2 mots recherchés
derligne = Cells(Rows.Count, 1).End(3).Row
For i = 2 To derligne
liste = "Badminton,foot" '--E1
x1 = Split(Cells(i, 1), Chr(10))
y = ""
Z = ""
For t = 0 To UBound(x1)
x = Split(x1(t), " ")
    For k = 0 To UBound(x)
        If InStr("," & liste & ",", "," & x(k) & ",") > 0 Then '--E2
        y = y + x1(t) + Chr(10)
        GoTo prochain
        Else
        End If
        Next k
Z = Z + x1(t) + Chr(10)
prochain:
Next t
Cells(i, 2) = Left(y, Len(y) - 1)
Cells(i, 3) = Left(Z, Len(Z) - 1)
Next i
End Sub

 

[job75]

Tu gagnerais encore un peu de temps en remplaçant tes deux fonctions IIF par deux instructions If ... then ... else (moins "confortables" mais beaucoup plus rapides)

Pa beaucoup mais un peu plus rapide : 1,4 seconde sur 60 000 lignes.

 

[jmfmarques]

Pa beaucoup mais un peu plus rapide

cela révèle donc un partage à peu près égal des deux clauses du if then else. La différence serait bien plus significative dans d'autres cas.

 

[job75]

La différence serait bien plus significative dans d'autres cas.

Oui s'il y avait beaucoup de cas d'effacement.

Les 3 arguments de la fonction IIf sont toujours évalués, l'évaluation de "" prend très peu de temps.

 

[job75]

Oui s'il y avait beaucoup de cas d'effacement.

Ben non, dans le fichier joint la 3ème colonne est toujours effacée et il y a peu de différence.

 

[Pexcel]

Ben non, dans le fichier joint la 3ème colonne est toujours effacée et il y a peu de différence.

Merci à tous pour vos réponses, est qu'il y a la possibilité de Job 75 ton exemple fonctionne parfaitement, mais peut on supprimer les renvoies de chariot inutiles, les vides, car des fois j'ai des saisies au départ du genre :

13/04/2017 : Initiation Badminton classe CE2
06/05/2018: tournoi Badminton Cm1/Cm2


01/03/2018: Match handball CE1 vs Ce2

27/05/2018: Initiation foot de salle CP

30/09/2018: Initiation Badminton CP : gymnase David Douillet

Dans la colonne B c'est bon mais dans C il y a des renvoies de chariots inutiles comme au départ.

 

[job75]

Il suffit d'ajouter le test If s(j) <> "" Then, le fichier en retour avec :

If s(j) <> "" Then If InStr(s(j), txt) Then x = x & vbLf & s(j) Else y = y & vbLf & s(j)

 

[Pexcel]

Merci, nickel !!!