Tester le contenu de plusieurs cellule et assigner des valeurs en cohérence

Bonjour,

J'ai vraiment cherché à me document sur les loop for / each / next avant de vous solliciter mais je ne trouve pas mon erreur!

Je souhaite créer une procédure pour :

(1) parcourir une plage de cellules (ma sélection)

(2) y chercher des valeurs précises

(3) si elle les trouve ajouter un contenu dans une cellule appropriée

Exemple :

première cellule parcourue contient "AFCO", "AFET", "AGRI" => ajout d'un "M" dans les cellules correspondant aux entêtes de colonne "AFCO", "AFET", "AGRI" sur la même ligne ;

seconde cellule parcourue contient "AGRI", "AFCO" => ajout d'un "M" dans les cellules correspondant aux entêtes de colonne "AFCO", "AGRI" sur la même ligne ;

troisième cellule parcourue ne contient pas les valeurs recherchées => pas d'ajout

etc.

J'ai tenté la macro suivante :

Sub membership()

Dim cellule As Range

For Each cellule In Selection

    If InStr(cellule, "AFCO") > 0 Then
        Range("M" & Selection.Row).Value = "M"

End If

    If InStr(cellule, "AFET") > 0 Then
        Range("O" & Selection.Row).Value = "M"
End If

    If InStr(cellule, "AGRI") > 0 Then
        Range("P" & Selection.Row).Value = "M"
End If

Next cellule

End Sub

Je rencontre plusieurs problèmes :

(1) le contenu n'est ajouté que pour la première cellule parcourue, pas pour les suivantes! :-( Est-ce que mon loop fonctionne ? J'en ai 700 à tester, une par une ça va être long!

(2) j'aurai au total 74 valeurs à rechercher, la multiplication de 74 blocs if / end if ne sera-t-elle pas problématique ? L'utilisation de select case serait il préférable ici ?

Voilà, un grand merci d'avance pour votre aide et vos réponses!

Merci!

Hello,

Je ferai comme ceci :

Sub membership()

Const strLetter As String = "M"

Dim bytrowtitle As Byte
Dim cellule As Range, rgseach As Range
Dim vararraymember As Variant
Dim objdico As Object
Dim j As Long, i As Long, lngrowrg As Long
Dim strmember As String

bytrowtitle = 1
Set objdico = CreateObject("Scripting.Dictionary")
j = 1
Do While Not IsEmpty(Cells(bytrowtitle, j))
    If Not objdico.exists(Cells(bytrowtitle, j).Value) Then objdico.Add Cells(bytrowtitle, j).Value, j
    j = j + 1
Loop

Set rgseach = Selection
For Each cellule In rgseach
    vararraymember = Split(cellule, ",")
    lngrowrg = cellule.Row
    For j = LBound(vararraymember) To UBound(vararraymember)
        strmember = vararraymember(j)
        If objdico.exists(strmember) Then Cells(lngrowrg, objdico(strmember)) = strLetter
    Next j
Next cellule

Set objdico = Nothing
Set rgseach = Nothing
End Sub

Si besoin je peux commenter

Bonsoir,

Une proposition Power Query à adapter !?
Cdlt.

Hello Jean-Eric,

Elle te sert à quoi la colonne Index ?

Hello Rag, Hello Jean-Eric,

N'ayant pas réussi à m'approprier la solution de Rag j'ai poursuivi mes efforts et ai trouvé une (modeste) solution :

Sub membership()

Dim cellule As Range

For Each cellule In Selection

If InStr(cellule, "AFCO") > 0 Then
    cellule.Offset(0, 1).Value = "M"
    End If

    If InStr(cellule, "AFET") > 0 Then
    cellule.Offset(0, 2).Value = "M"
End If

    If InStr(cellule, "AGRI") > 0 Then
    cellule.Offset(0, 3).Value = "M"
End If

Next cellule

End Sub

Cela règle mon premier problème : le marquage s'effectue désormais sur toutes les lignes de la sélection. Reste à voir comment cela réagira quand j'aurai entré mes 71 autres tests de contenus... à voir.

Ce n'est sans doute pas très propre et cela demanderait certainement à être optimisé mais je débute, et dans l'idéal j'essaie de comprendre les solutions que j'applique pour progresser.

Si cela coince, j'adapterai la solution de Jean-Eric qui m'apparaît prête-à-l'emploi (un peu loin de mes compétences actuelles, mais j'essaierai de l'adapter).

Merci à tous les deux en tous cas!

Guillaume

Re,

@Rag02700,

J'ai supprimé l'index dans le fichier de mon message initial.
CdlT.

Hello,

@Jean-Eric, ce n'était pas une critique mais juste que je me posais la question car il me semblait qu'elle n'était pas utilisée, je pensais avoir loupé une étape

@Guillaume j'ai oublié de te dire d'enlever l' espace après la virgule dans ta colonne A

Bonjour,

@Rag02700,
Ta remarque m'a gâché ma journée.
Bonne soirée.

Bonjour,

guillaume, tu as ElseIf aussi :

If ... ' test1

ElseIf ... ' test2

ElseIf ... ' test3

End If

dès qu'un est réalisé tu quittes le If global

quand j'aurai entré mes 71 autres tests de contenus....

dans ce cas il faut écrire tes valeurs sur feuille et les récupérer dans un tableau.
Et boucler sur ton tableau pour faire le test
eric

Bonsoir,

Ou encore :

Sub MemberShip()
Dim Cell As Range
    For Each Cell In Selection
        Select Case True
        Case InStr(Cell, "AFCO") > 0: Cell.Offset(0, 1).Value = "M"
        Case InStr(Cell, "AFET") > 0: Cell.Offset(0, 2).Value = "M"
        Case InStr(Cell, "AGRI") > 0: Cell.Offset(0, 3).Value = "M"
        End Select
    Next Cell
End Sub

Merci à tous, je vous aurai bien mis à tous "résolu" mais mon choix s'est porté sur la solution la plus compréhensible pour mon petit niveau!

Impressionnant votre maîtrise en tous cas!