Moteur de recherche encore et toujours ;-)

M

Marion

XLDnaute Junior
Bonsoir à tous,
je continue avec mon moteur de recherche...j'avance bien mais j'ai une procédure qui ne fonctionne pas. En fait, la première recherche d'un contrat particulier fonctionne mais celle qui recherche tous les contrats par type de modification ne marche pas du tout. Elle marchait hier soir mais là plus du tout et je sais pas ce que j'ai touché ...grrrrrrr
Gorfaël si tu peux m'accorder quelques minutes :eek:
J'exporte l'USF...et je le joins
Merci par avance, Marion

Heu non je le copie parce que je n'ai que les compressions .rar et que le temps que je télécharge winzip j'aurai plus de cheveux :cool:
je joins quand même le fichier sans les macros pour bien comprendre

Option Explicit
Private Sub Cbo_Contrat_Change()
If Me.Cbo_Contrat.ListIndex >= 0 Then
Me.CdeValider.Enabled = True
Else
Me.CdeValider.Enabled = True
End If
End Sub

Private Sub Cbo_modification_Change()
If Me.Cbo_modification.ListIndex >= 0 Then
Me.CdeValider.Enabled = True
Else
Me.CdeValider.Enabled = False
End If
End Sub

Private Sub Cde_Quit_Click()
Unload Me
End Sub

Private Sub CdeValider_Click()
Dim vContrat As String
Dim vRéponse As String
Dim vInstruction As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim flg_Test As Boolean
vContrat = Trim(Cbo_Contrat)
vInstruction = Trim(Cbo_modification)

Unload USF_Rech
For k = 1 To Sheets("Tableau").Range("B65536").End(xlUp).Row
If Sheets("Tableau").Cells(k, 2).Value = vContrat Then
Sheets("Recherche").Range("E6") = Sheets("Tableau").Cells(k, 1)
For i = 4 To 8
If Sheets("Tableau").Cells(k, i) <> "" Then
Sheets("Recherche").Range("E8") = Sheets("Tableau").Cells(k, i)
Sheets("Recherche").Range("E7") = Sheets("Tableau").Cells(2, i)
flg_Test = True
Exit For
End If
Next i
flg_Test = True
Exit For
End If
Next k

If flg_Test = False Then
If Len(vContrat) < 8 Then
vRéponse = MsgBox("Veuillez entre un n° de contrat à 8 caractères", vbOKOnly, "Attention")
Load USF_Rech
USF_Rech.Show
End If
vRéponse = MsgBox("Ce contrat n'a pas été modifié sur la période." & Chr(10) & "Voulez vous saisir un nouveau contrat ?", vbYesNo + vbInformation, "Attention")
If vRéponse = vbNo Then Unload USF_Rech
If vRéponse = vbYes Then USF_Rech.Show
End If

For k = 4 To Sheets("Tableau").Range("B65536").End(xlUp).Row
Dim LigneARajoutee As Integer
If vInstruction = "M.E.L." Then
If Sheets("Tableau").Cells(k, 4) <> "" Then
LigneARajoutee = Sheets("Recherche").Range("C65536").End(xlUp).Row + 1
Sheets("Recherche").Range("C" & LigneARajoutee).Value = Sheets("Tableau").Cells(k, 2).Value
Sheets("Recherche").Range("D" & LigneARajoutee).Value = Sheets("Tableau").Cells(k, 4).Value
If vInstruction = "Cession" Then
If Sheets("Tableau").Cells(k, 6) <> "" Then
LigneARajoutee = Sheets("Recherche").Range("C65536").End(xlUp).Row + 1
Sheets("Recherche").Range("C" & LigneARajoutee).Value = Sheets("Tableau").Cells(k, 2).Value
Sheets("Recherche").Range("D" & LigneARajoutee).Value = Sheets("Tableau").Cells(k, 6).Value
If vInstruction = "Régularisation" Then
If Sheets("Tableau").Cells(k, 5) <> "" Then
LigneARajoutee = Sheets("Recherche").Range("C65536").End(xlUp).Row + 1
Sheets("Recherche").Range("C" & LigneARajoutee).Value = Sheets("Tableau").Cells(k, 2).Value
Sheets("Recherche").Range("D" & LigneARajoutee).Value = Sheets("Tableau").Cells(k, 5).Value
If vInstruction = "Patrimoine" Then
If Sheets("Tableau").Cells(k, 7) <> "" Then
LigneARajoutee = Sheets("Recherche").Range("C65536").End(xlUp).Row + 1
Sheets("Recherche").Range("C" & LigneARajoutee).Value = Sheets("Tableau").Cells(k, 2).Value
Sheets("Recherche").Range("D" & LigneARajoutee).Value = Sheets("Tableau").Cells(k, 7).Value
End If
End If
End If
End If
End If
End If
End If
End If
Next k

End Sub

Private Sub Crit_1_AfterUpdate()

End Sub

Private Sub Lbl_Titre_Click()

End Sub

Private Sub Userform_Initialize()
Me.Sel_Fonction.Value = 0
Dim Cel As Range
Dim x
For Each Cel In Sheets("tableau").Range(Sheets("tableau").[B4], _
Sheets("tableau").[B65536].End(xlUp))
Me.Cbo_Contrat.AddItem Cel.Value
Next Cel
Call Sel_Fonction_Change
End Sub

Private Sub Sel_Fonction_Change()
'1 : Contrat 2:Type de modification 3:période
Select Case Me.Sel_Fonction.Value
Case 0 'Contrat
Me.Lbl_Titre = "Recherche par numéro de contrat"
Me.Caption = "RECHERCHE PAR CONTRAT"
Me.Lbl_Crit_1 = "Numéro du Contrat"
Me.Cbo_Contrat.Text = ""
Me.Cbo_Contrat.Visible = True
Me.Cbo_Contrat.SetFocus
Me.Crit_1.Visible = False
Me.Crit_2.Visible = False
Me.Lbl_Crit_2.Visible = False
Me.Cbo_modification.Visible = False
Case 1 'Type de modification
Me.Lbl_Titre = "Recherche par type de modification"
Me.Caption = "RECHERCHE PAR TYPE DE MODIFICATION"
Me.Lbl_Crit_1 = "Type de modification"
Me.Cbo_modification.Visible = True
Me.Cbo_modification.Clear
Me.Cbo_modification.SetFocus
Me.Cbo_modification.AddItem "M.E.L."
Me.Cbo_modification.AddItem "Cession"
Me.Cbo_modification.AddItem "Régularisation"
Me.Cbo_modification.AddItem "Patrimoine"
Me.Crit_1.Visible = False
Me.Cbo_Contrat.Visible = False
Me.Crit_2.Visible = False
Me.Lbl_Crit_2.Visible = False
Case 2 'Période
Me.Lbl_Titre = "Recherche par Période"
Me.Caption = "RECHERCHE PAR DATES"
Me.Lbl_Crit_1 = "Date de début"
Me.Crit_1.Text = ""
Me.Crit_2.Text = ""
Me.Crit_1.Visible = True
Me.Lbl_Crit_1.Visible = True
Me.Crit_1.SetFocus
Me.Cbo_Contrat.Visible = False
Me.Cbo_modification.Visible = False
Me.Crit_2.Visible = True
Me.Lbl_Crit_2.Visible = True
Me.Crit_2.SetFocus
End Select
End Sub
 

Pièces jointes

  • test programme immo.xls
    27.5 KB · Affichages: 40
Trier par date Trier par votes
Gorfael

Gorfael

XLDnaute Barbatruc
Re : Moteur de recherche encore et toujours ;-)

Salut Marion
Heu non je le copie parce que je n'ai que les compressions .rar et que le temps que je télécharge winzip j'aurai plus de cheveux
Compression en RAR ? Winrar fait aussi du Zip
pour les cheveux, moi, c'est un peu tard :p

Comme je n'ai pas l'USF, j'ai juste jeté un cil sur le code :eek:

Je suis dessus, et j'essaie de le comprendre

Encore des trucs à apprendre petit scarabé :D
A+
EDIT : Je viens juste de répondre, et je trouve l'USF
Je vais pouvoir m'amuser, mais demain
 

Pièces jointes

  • Explications macro.xls
    27.5 KB · Affichages: 46
Dernière édition:
Vote positif 0 Vote négatif
M

Marion

XLDnaute Junior
Re : Moteur de recherche encore et toujours ;-)

Gorfael à dit:
Salut Marion
Heu non je le copie parce que je n'ai que les compressions .rar et que le temps que je télécharge winzip j'aurai plus de cheveux :cool:
Compression en RAR ? Winrar fait aussi du Zip
End Sub
Cliquez pour agrandir...

Ah heu winrar fait du zip en effet :rolleyes:
-la honte- :cool:

Bon là je joins l'usf parce que après "incrémentation" je ne vois pas de end if qui manquent, en effet, les deux seuls que j'aurais pu rajouter, ils ne passent pas.

Merci pour ton coup de cil et de me consacrer autant de temps :D
Marion
 

Pièces jointes

  • USF.zip
    2.7 KB · Affichages: 34
  • USF.zip
    2.7 KB · Affichages: 33
  • USF.zip
    2.7 KB · Affichages: 34
Vote positif 0 Vote négatif
Gorfael

Gorfael

XLDnaute Barbatruc
Re : Moteur de recherche encore et toujours ;-)

Marion à dit:
Ah heu winrar fait du zip en effet :rolleyes:
-la honte- :cool:

Bon là je joins l'usf parce que après "incrémentation" je ne vois pas de end if qui manquent, en effet, les deux seuls que j'aurais pu rajouter, ils ne passent pas.

Merci pour ton coup de cil et de me consacrer autant de temps :D
Marion
Cliquez pour agrandir...
salut
dans ma macro, il manque un endif
Private Sub CdeValider_Click()
Dim vContrat As String
Dim vRéponse As String
Dim vInstruction As String
Dim i As Integer
Dim j As Integer
Dim k As Long
Dim flg_Test As Boolean
Dim LigneARajoutee As Integer
Dim F_T As Worksheet
Dim F_R As Worksheet
vContrat = Trim(Cbo_Contrat)
vInstruction = Trim(Cbo_modification)
Set F_R = Sheets("Recherche")
Set F_T = Sheets("Tableau")
Unload USF_Rech
For k = 1 To F_T.Range("B65536").End(xlUp).Row
If F_T.Range("B" & k) = vContrat Then
F_R.Range("E6") = F_T.Range("A" & k)
For i = 4 To 8
If F_T.Cells(k, i) <> "" Then
F_R.Range("E8") = F_T.Cells(k, i)
F_R.Range("E7") = F_T.Cells(2, i)
Exit For
End If
Next i
flg_Test = True
Exit For
End If
Next k
If flg_Test = False Then
If Len(vContrat) < 8 Then
vRéponse = MsgBox("Veuillez entre un n° de contrat à 8 caractères", _
vbOKOnly, "Attention")
USF_Rech.Show
Exit Sub
End If
vRéponse = MsgBox("Ce contrat n'a pas été modifié sur la période." & Chr(10) _
& "Voulez vous saisir un nouveau contrat ?", _
vbYesNo + vbInformation, "Attention")
If vRéponse = vbYes Then USF_Rech.Show
Exit Sub
End If
Select Case vInstruction
Case "M.E.L."
i = 4
Case "Régularisation"
i = 5
Case "Cession"
i = 6
Case "Patrimoine"
i = 7
End Select
For k = 4 To F_T.Range("B65536").End(xlUp).Row
If F_T.Cells(k, i) <> "" Then
LigneARajoutee = F_R.Range("C65536").End(xlUp).Row + 1
F_R.Range("C" & LigneARajoutee) = F_T.Range("B" & k)
F_R.Range("D" & LigneARajoutee) = F_T.Cells(k, i)
End If
Next k
End Sub
A+
 
Vote positif 0 Vote négatif
M

Marion

XLDnaute Junior
Re : Moteur de recherche encore et toujours ;-)

Merci, merci et re-merci pour ton aide...J'ai aussi cherché de mon côté et ça fonctionne nickel !!:D
Je crois que j'ai enfin compris le fonctionnement des if end if , else et for next :)

Mais il est vrai que les case sont plus clairs...
Je regarderai mais j'avance bien !!

En t k ça m'a bouffé tout mon we j'espère pas trop le tien :cool:

Bonne soirée
 
Vote positif 0 Vote négatif
M

Marion

XLDnaute Junior
Re : Moteur de recherche encore et toujours ;-)

Je viens de voir ton fichier d'explication t'as fait un gros boulot vraiment et ça va beaucoup m'aider..........j'suis un peu confuse de t'en demander autant
mais petit scarabée apprend ......
Une élève docile ;-)
 
Vote positif 0 Vote négatif

Discussions similaires

B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
278
Compte Supprimé 979
C
F
  • Résolu(e)
Microsoft 365 Recherche à partir d'une TextBox
Réponses
4
Affichages
200
Francky79
F
S
  • Résolu(e)
Microsoft 365 Récupérer la date dans un calendrier
Réponses
2
Affichages
155
sebastien176
S
D
  • Question
XL 2010 Identification d'une cellule cliquée
Réponses
6
Affichages
390
dadu35
D
D
  • Question
XL 2021 Filtre Multi Critères Listview VBA
2
Réponses
21
Affichages
435
Dranreb
Dranreb
D
  • Question
XL 2010 Valoriser cellule par clic
Réponses
4
Affichages
267
fanch55
fanch55
P
  • Question
XL 2019 VBA moteur de recherche
2
Réponses
21
Affichages
1 K
philgood54000
P
R
  • Question
XL 2016 excel 2016 VBA
Réponses
2
Affichages
181
rebatte
R
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
106
Latias
L
T
  • Question
XL 2016 Optimisation d'une boucle
2 3
Réponses
30
Affichages
1 K
thivame
T

Membres actuellement en ligne

10 membres et 94 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 488
Messages
2 088 835
Membres
103 972
dernier inscrit
steeter