Rechercher dans 2 colonnes

T

totoff55

XLDnaute Nouveau
Bonsoir,
Je suis novice sue excel et je bloque sur une recherche.
J'ai en colonne A une liste de titre de films existants, en colonne B, une liste des titres achetés. Je voudrais en colonne C inscrire les titres restants à achetés. Sachant que je n'achète pas forcément les titres dans l'ordre de la colonne A.
Je ne voudrais pas une macro car je veux que cela s'affiche dés que j'ai entré le titre acheté.
Je vous remercie pour votre aide si précieuse.
cricri
 

Pièces jointes

  • Test.xlsx
    10.5 KB · Affichages: 34
Trier par date Trier par votes
BOISGONTIER

BOISGONTIER

XLDnaute Barbatruc
Repose en paix
Bonjour,

Version avec ajout/suppression dans le formulaire de Titres existants

Code: 
Option Compare Text
Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Me.Source.List = f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value
  Me.Dest.List = f.Range("B2:B" & f.[B65000].End(xlUp).Row).Value
  ListeManque
  ListeSeries
End Sub

Private Sub b_prend_Click()
  If Me.Source.ListIndex <> -1 And Me.Source.ListCount > 0 Then
     Item = Me.Source '.List(i)
     If Me.Dest.ListCount > 0 Then
       Tbl = Me.Dest.List
       p = Application.Match(Item, Application.Index(Tbl, 0), 0)
       If IsError(p) Then Me.Dest.AddItem Item
     Else
       Me.Dest.AddItem Item
     End If
  End If
  ListeManque
End Sub

Private Sub B_enlève_Click()
  If Me.Dest.ListCount > 0 And Me.Dest.ListIndex <> -1 Then Me.Dest.RemoveItem Me.Dest.ListIndex
  ListeManque
End Sub
Sub ListeManque()
  Set d = CreateObject("scripting.dictionary")
  For i = 0 To Dest.ListCount - 1
    d(Me.Dest.List(i)) = ""
  Next i
  Set d2 = CreateObject("scripting.dictionary")
  For i = 0 To Source.ListCount - 1
    tmp = Me.Source.List(i, 0)
    If Not d.exists(tmp) Then d2(tmp) = ""
  Next i
  Me.ListBox1.List = d2.keys
End Sub

Private Sub B_transfert_bd_Click()
   Tbl = f.Range("B2:B" & f.[B65000].End(xlUp).Row).Value
   Set d = CreateObject("scripting.dictionary")
   For i = 1 To UBound(Tbl)
     tmp = Tbl(i, 1)
     d(tmp) = ""
   Next i
   '-- sup série
   For i = 1 To UBound(Tbl)
     tmp = Tbl(i, 1)
     If tmp Like Me.ComboBox1 & "*" Then d.Remove (tmp)
   Next i
   '-- nv série
   Tbl1 = Me.Dest.List
   For i = 0 To Me.Dest.ListCount - 1
     tmp = Tbl1(i, 0)
     d(tmp) = ""
   Next i
   f.[B2:B1000].ClearContents
   f.[B2].Resize(d.Count) = Application.Transpose(d.keys)
   f.[B2].Resize(d.Count).Sort key1:=[B2], Header:=no
End Sub

Sub ListeSeries()
    Set d = CreateObject("scripting.dictionary")
    d("*") = ""
    Tbl = f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value
    For i = 1 To UBound(Tbl)
      p = InStr(Tbl(i, 1), "Saison")
      If p > 0 Then
        tmp = Trim(Left(Tbl(i, 1), p - 1))
        d(tmp) = ""
      End If
    Next i
    Me.ComboBox1 = "*"
    Me.ComboBox1.List = d.keys
End Sub

Private Sub ComboBox1_Click()
Tbl1 = f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value
Tbl3 = f.Range("B2:B" & f.[B65000].End(xlUp).Row).Value
Dim Tbl2()
choix = Me.ComboBox1 & "*"
n = 0
For i = 1 To UBound(Tbl1)
  If Tbl1(i, 1) Like choix Then
     n = n + 1: ReDim Preserve Tbl2(1 To n)
     Tbl2(n) = Tbl1(i, 1)
   End If
Next i
Me.Source.List = Tbl2
'--
Dim Tbl4()
n = 0
For i = 1 To UBound(Tbl3)
  If Tbl3(i, 1) Like choix Then
     n = n + 1: ReDim Preserve Tbl4(1 To n)
     Tbl4(n) = Tbl3(i, 1)
   End If
Next i
If n > 0 Then Me.Dest.List = Tbl4 Else Me.Dest.Clear
ListeManque
End Sub

Private Sub B_ajout_Click()
  If Me.TextBox1 <> "" Then
    If InStr(Me.TextBox1, "saison") = 0 Then
       MsgBox "Manque saison!"
       Me.TextBox1.SetFocus
       Exit Sub
    End If
    n = f.[A65000].End(xlUp).Row
    Cells(n + 1, "a") = Me.TextBox1
    Me.TextBox1 = ""
    f.[A2].Resize(n + 1).Sort key1:=[A2], Header:=no
    UserForm_Initialize
  End If
End Sub

Private Sub B_sup_Click()
  If Me.Source.ListCount > 0 And Me.Source.ListIndex <> -1 Then
    tmp = Me.Source
    Set p = f.[A:A].Find(tmp)
    If Not p Is Nothing Then
      If MsgBox("Etes vous sûr de supprimer " & tmp & "?", vbYesNo) = vbYes Then
        f.Cells(p.Row, "a").Delete Shift:=xlUp
        UserForm_Initialize
      End If
    End If
  End If
  ListeManque
End Sub


jb
 

Pièces jointes

  • Suivi_Series4.xls
    153.5 KB · Affichages: 25
Dernière édition:
Vote positif 0 Vote négatif
T

totoff55

XLDnaute Nouveau
BOISGONTIER à dit:
Bonjour,

Version avec ajout/suppression dans le formulaire de Titres existants

Code: 
Option Compare Text
Dim f
Private Sub UserForm_Initialize()
  Set f = Sheets("BD")
  Me.Source.List = f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value
  Me.Dest.List = f.Range("B2:B" & f.[B65000].End(xlUp).Row).Value
  ListeManque
  ListeSeries
End Sub

Private Sub b_prend_Click()
  If Me.Source.ListIndex <> -1 And Me.Source.ListCount > 0 Then
     Item = Me.Source '.List(i)
     If Me.Dest.ListCount > 0 Then
       Tbl = Me.Dest.List
       p = Application.Match(Item, Application.Index(Tbl, 0), 0)
       If IsError(p) Then Me.Dest.AddItem Item
     Else
       Me.Dest.AddItem Item
     End If
  End If
  ListeManque
End Sub

Private Sub B_enlève_Click()
  If Me.Dest.ListCount > 0 And Me.Dest.ListIndex <> -1 Then Me.Dest.RemoveItem Me.Dest.ListIndex
  ListeManque
End Sub
Sub ListeManque()
  Set d = CreateObject("scripting.dictionary")
  For i = 0 To Dest.ListCount - 1
    d(Me.Dest.List(i)) = ""



  Next i
  Set d2 = CreateObject("scripting.dictionary")
  For i = 0 To Source.ListCount - 1
    tmp = Me.Source.List(i, 0)
    If Not d.exists(tmp) Then d2(tmp) = ""
  Next i
  Me.ListBox1.List = d2.keys
End Sub

Private Sub B_transfert_bd_Click()
   Tbl = f.Range("B2:B" & f.[B65000].End(xlUp).Row).Value
   Set d = CreateObject("scripting.dictionary")
   For i = 1 To UBound(Tbl)
     tmp = Tbl(i, 1)
     d(tmp) = ""
   Next i
   '-- sup série
   For i = 1 To UBound(Tbl)
     tmp = Tbl(i, 1)
     If tmp Like Me.ComboBox1 & "*" Then d.Remove (tmp)
   Next i
   '-- nv série
   Tbl1 = Me.Dest.List
   For i = 0 To Me.Dest.ListCount - 1
     tmp = Tbl1(i, 0)
     d(tmp) = ""
   Next i
   f.[B2:B1000].ClearContents
   f.[B2].Resize(d.Count) = Application.Transpose(d.keys)
   f.[B2].Resize(d.Count).Sort key1:=[B2], Header:=no
End Sub

Sub ListeSeries()
    Set d = CreateObject("scripting.dictionary")
    d("*") = ""
    Tbl = f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value
    For i = 1 To UBound(Tbl)
      p = InStr(Tbl(i, 1), "Saison")
      If p > 0 Then
        tmp = Trim(Left(Tbl(i, 1), p - 1))
        d(tmp) = ""
      End If
    Next i
    Me.ComboBox1 = "*"
    Me.ComboBox1.List = d.keys
End Sub

Private Sub ComboBox1_Click()
Tbl1 = f.Range("A2:A" & f.[A65000].End(xlUp).Row).Value
Tbl3 = f.Range("B2:B" & f.[B65000].End(xlUp).Row).Value
Dim Tbl2()
choix = Me.ComboBox1 & "*"
n = 0
For i = 1 To UBound(Tbl1)
  If Tbl1(i, 1) Like choix Then
     n = n + 1: ReDim Preserve Tbl2(1 To n)
     Tbl2(n) = Tbl1(i, 1)
   End If
Next i
Me.Source.List = Tbl2
'--
Dim Tbl4()
n = 0
For i = 1 To UBound(Tbl3)
  If Tbl3(i, 1) Like choix Then
     n = n + 1: ReDim Preserve Tbl4(1 To n)
     Tbl4(n) = Tbl3(i, 1)
   End If
Next i
If n > 0 Then Me.Dest.List = Tbl4 Else Me.Dest.Clear
ListeManque
End Sub

Private Sub B_ajout_Click()
  If Me.TextBox1 <> "" Then
    If InStr(Me.TextBox1, "saison") = 0 Then
       MsgBox "Manque saison!"
       Me.TextBox1.SetFocus
       Exit Sub
    End If
    n = f.[A65000].End(xlUp).Row
    Cells(n + 1, "a") = Me.TextBox1
    Me.TextBox1 = ""
    f.[A2].Resize(n + 1).Sort key1:=[A2], Header:=no
    UserForm_Initialize
  End If
End Sub

Private Sub B_sup_Click()
  If Me.Source.ListCount > 0 And Me.Source.ListIndex <> -1 Then
    tmp = Me.Source
    Set p = f.[A:A].Find(tmp)
    If Not p Is Nothing Then
      If MsgBox("Etes vous sûr de supprimer " & tmp & "?", vbYesNo) = vbYes Then
        f.Cells(p.Row, "a").Delete Shift:=xlUp
        UserForm_Initialize
      End If
    End If
  End If
  ListeManque
End Sub

MERCI infiniment impeccable
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif

Discussions similaires

B
  • Résolu(e)
XL 2019 Classer en ordre alphabétique plusieurs colonnes
Réponses
8
Affichages
660
job75
job75
A
  • Question
Microsoft 365 Réorganiser les colonnes de plusieurs fichiers automatiquement par VBA
Réponses
2
Affichages
431
mapomme
mapomme
M
  • Question
Microsoft 365 Tri de titre de colonnes
Réponses
2
Affichages
798
moanin
M
T
  • Résolu(e)
Microsoft 365 Transformer les données d'une colonne en fonction de 2 autres colonnes
Réponses
5
Affichages
504
Tidjyphenom
T
N
  • Résolu(e)
XL 2019 copier 2 colonnes d'un classeur A et coller les données dans une seule colonne dans un classeur B
Réponses
14
Affichages
452
Dranreb
Dranreb
S
  • Question
XL 2019 Rechercher une valeur dans une table, multi-critère
Réponses
7
Affichages
1 K
SylviaCil
S
B
  • Résolu(e)
XL 2016 Déduire une valeur médiane en fonction de 2 autres cellules : Nomogramme
Réponses
10
Affichages
1 K
BenEro
B
N
  • Question
XL 2016 Macro rechercher valeur cellule + copier-coller ligne dans tableau
Réponses
4
Affichages
6 K
Nairolf
N
cp4
  • Résolu(e)
Autres Séparer Numéro du texte dans 2 colonnes différentes
2 3
Réponses
43
Affichages
2 K
Staple1600
Staple1600
C
  • Question
Autres VBA - Copier valeur cellule variable dans autre feuille sous condition Excel 2007
Réponses
3
Affichages
2 K
claivier_58
C

Membres actuellement en ligne

2 membres et 34 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 348
Messages
2 087 510
Membres
103 570
dernier inscrit
patrickb83p