Microsoft 365 VBA EXCEL Utilisation d'une variable avec données dans un tableau

[INFSON]

Bonjour

Je mets en pièce jointe un fichier excel test avec la macro de fin de message

J'ai écrit une macro dont le but est de mettre à jour les colonnes F et G de la feuille FLUX en fonction d'un mot trouvé dans la colonne D
La macro fonctionne mais n'est pas très fonctionnelle en cas de mots nombreux

Je souhaiterais utiliser plutôt le passage des valeurs à l'aide d'une variable reprenant les données d'une table se trouvant dans la feuille CATEGORIE
Le programme doit mettre dans la variable le mot se trouvant en B2 (dans l'exemple "Mérovingien")
Rechercher ce mot dans la colonne D de la feuille FLUX s'il est présent mettre sur la ligne repérée la valeur A2 de la feuille CATEGORIE (dans l'exemple "MOYEN-AGE" en colonne F et la valeur B2 (dans l'exemple en colonne G "Mérovingien"

Puis le programme donne à la boucle la valeur B3 de la feuille CATEGORIE à rechercher avec même traitement exprimé ci-dessus

Et ainsi de suite jusqu'à fin de la colonne B de la feuille CATEGORIE

Comment écrire ce code ?

Merci d'avance


Sub FLUX()
Dim FL1 As Worksheet, NoCol As Integer
Dim NoLig As Long, Var As Variant
Dim mot As Variant
Set FL1 = Worksheets("FLUX")
'mot = InputBox("Quel mot?")
NoCol = 4 'lecture de la colonne 1
Range("D2").Select
For NoLig = 1 To Split(FL1.UsedRange.Address, "$")(4)
Var = FL1.Cells(NoLig, NoCol)
'MsgBox (ActiveCell.Value)
If ActiveCell.Offset(0, 2).Value = "" Then

Select Case ActiveCell.Value <> "X"
Case ActiveCell.Value Like "Rome*"
ActiveCell.Offset(0, 3).Value = "Rome"
ActiveCell.Offset(0, 2).Value = "ANTIQUITE"

Case ActiveCell.Value Like "*Néandertal*"
ActiveCell.Offset(0, 3).Value = "Néandertal"
ActiveCell.Offset(0, 2).Value = "PREHISTOIRE"

Case ActiveCell.Value Like "*mérovingien*"
ActiveCell.Offset(0, 3).Value = "Mérovingien"
ActiveCell.Offset(0, 2).Value = "MOYEN-AGE"

Case ActiveCell.Value Like "*Celtes*"
ActiveCell.Offset(0, 3).Value = "Celtes"
ActiveCell.Offset(0, 2).Value = "ANTIQUE"

Case ActiveCell.Value Like "*médiévale*"
ActiveCell.Offset(0, 3).Value = "médiévale"
ActiveCell.Offset(0, 2).Value = "MOYEN-AGE"
'médiévale

Case Else

End Select


End If
ActiveCell.Offset(1, 0).Select
Next
Set FL1 = Nothing
End Sub

 

[mapomme]

Bonjour @INFSON ,

Avec Office 365, une formule devrait suffire.
Pour être plus pratique, le tableau de la feuille "CATEGORIE" a été transformé en tableau structuré (de nom Tableau1). Si on modifie, insère ou supprime des lignes dans Tableau1, la formule de la feuille FLUX reste inchangée et correcte.

La formule suivante est à saisir dans la seule cellule F2 de la feuille "FLUX" puis à recopier vers le bas :

=SIERREUR(CHOISIRLIGNES( FILTRE(Tableau1;NB.SI(D2;"*"&Tableau1[CAT2]&"*")>0);1);"")

 

[mapomme]

Re,
Toujours en O365:
Pour le code VBA, copier le code ci-dessous dans le module de la feuille "Flux".
Les colonnes F et G de la feuille "Flux" sont mises à jour :

1. quand on modifie la colonne D de la feuille Flux
2. quand on active la feuille "Flux" (pour intégrer le cas où on modifie "Tableau1 et qu'ensuite on revient sur la feuille "Flux")

Private Sub Worksheet_Change(ByVal Target As Range)
   If Not Intersect(Columns("d:d"), Target) Is Nothing Then FormuleTAG1
End Sub

Private Sub Worksheet_Activate()
   FormuleTAG1
End Sub

Sub FormuleTAG1()
Dim der&
   Application.ScreenUpdating = False
   On Error GoTo FIN
   Application.EnableEvents = False
   With Sheets("FLUX")
      If .FilterMode Then .ShowAllData
      der = .Cells(.Rows.Count, "d").End(xlUp).Row
      .Range(.Range("f2"), .Cells(Rows.Count, "g")).ClearContents
      .Range("f2").Formula2R1C1 = "=IFERROR(CHOOSEROWS( FILTER(Tableau1,COUNTIF(RC[-2],""*""&Tableau1[CAT2]&""*"")>0),1),"""")"
      .Range("f2").Copy .Range("f2:f" & der)
   End With
FIN:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

 

[INFSON]

Merci de vos réponses , ça fonctionne très bien
Je n'aurai pas su faire ce code tout seul
Je vais essayer de comprendre , c'est pas, gagné

 

[mapomme]

Re ,

D'emblée, je ne commente jamais mes codes sauf si on me le demande.
Si vous le désirez, vous pouvez me solliciter.