Discussion :

[graphikris]

Bonjour,
J'ai essayé d'adapter la macro de Mr Boigontier Jacques mais j'éprouve pas mal de difficultés.



Ma feuille se nomme "Suivi Referentiel documentaire"
La recherche se fait à partir de la colonne E (TitreDocument) puis par type de document (colonne D).
A partir de ces deux recherches, le reste doit apparaître.

J'ai joint le fichier de Mr Boisgontier ainsi que le mien

Voici mon code qui ne fonctionne pas : bloque à la ligne 23

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Option Compare Text
Dim f, ligneEnreg, choix1()
Private Sub UserForm_Initialize()
  Set f = Sheets("Suivi Referentiel documentaire")
  choix1 = Application.Transpose(f.Range("E2:E" & f.[E65000].End(xlUp).Row).Value)
  Me.ChoixTitre.List = SansDoublons(choix1)
  ligneEnreg = f.[E65000].End(xlUp).Row + 1
  Me.ChoixTitre.SetFocus
End Sub
Private Sub ChoixTitre_Change()
  If Me.ChoixTitre.ListIndex = -1 And IsError(Application.Match(Me.ChoixTitre, choix1, 0)) Then
   Me.ChoixTitre.List = Filter(SansDoublons(choix1), Me.ChoixTitre.Text, True, vbTextCompare)
   Me.ChoixTitre.DropDown
  Else
    ChoixTitre_click
  End If
End Sub
Private Sub ChoixTitre_click()
  'For k = 1 To 4
  '  Me("Textbox" & k) = ""
  ' Next k
  a = f.Range("E2:D" & f.[D65000].End(xlUp).Row).Value
  Dim b(): ReDim b(1 To UBound(a))
  j = 0
  For i = 1 To UBound(a)
     If a(i, 1) = Me.ChoixTitre Then j = j + 1: b(j) = a(i, 2)
  Next i
  ReDim Preserve b(1 To j)
  Me.ChoixType.List = b
  Me.ChoixType.SetFocus
  If Val(Application.Version) > 10 Then SendKeys "{f4}"
End Sub
Private Sub ChoixType_click()
 For i = 2 To f.[D65000].End(xlUp).Row
  If f.Cells(i, "a") = Me.ChoixTitre And f.Cells(i, "b") = Me.ChoixType Then
    ligneEnreg = i
    For Each c In Me.Frame_Civilite.Controls
     If f.Cells(ligneEnreg, "c") = c.Caption Then c.Value = True
    Next c
    Me.Controls("TextBox1") = f.Cells(ligneEnreg, 1)
    Me.Controls("TextBox2") = f.Cells(ligneEnreg, 2)
    For k = 3 To 6
        Me.Controls("TextBox" & k) = f.Cells(ligneEnreg, k + 1)
      Next k
    End If
  Next i
End Sub
 
Function SansDoublons(a())
   Set d = CreateObject("Scripting.Dictionary")
   For Each c In a
      d(c) = ""
   Next c
   b = d.keys
   SansDoublons = b
End Function

Y a t'il une âme charitable pour m'aider ?

Cordialement