Rechercher dans 2 colonnes

BOISGONTIER à dit:

Avec cette version, on peut transférer les maj d'une série du formulaire dans la feuille du tableur (à tester)

http://boisgontierjacques.free.fr/fichiers/Formulaire/SuiviSeries.xls

jb

Cliquez pour agrandir...

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...