Code ne renvoi pas bonnes valeurs

[Résolu/Fermé]
Signaler
Messages postés
374
Date d'inscription
jeudi 11 août 2016
Statut
Membre
Dernière intervention
13 janvier 2020
-
Messages postés
374
Date d'inscription
jeudi 11 août 2016
Statut
Membre
Dernière intervention
13 janvier 2020
-
Bonjour,
Le code ci-dessous ne renvoi pas les bonnes valeurs dans la feuille Perso
Je vous remercie de bien vouloir le corriger

https://www.cjoint.com/c/GHAhe1YDxzU

Sub Valider_Click() 'OK
Application.ScreenUpdating = False
'Transfére des données ListBox dans la Feuille Perso
Application.ScreenUpdating = False
Dim f As Worksheet
Dim R As Range
Dim c As Range
Dim a As String

If IsNull(ListBox2.Value) Then MsgBox "Vous devez effectuer une selection !", vbCritical + vbOKOnly, " Aucun contact sélectionné": Exit Sub

'Chercher le nom et le prénom dans la base de données
With Worksheets("Base")
Set R = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
End With
Set c = R.Find(What:=ListBox2.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then a = c.Address
Do While Not c Is Nothing
'Vérifier le prénom
If c.Offset(0, 1).Value = ListBox2.List(ListBox2.ListIndex, 1) Then Exit Do
Set c = R.FindNext
If c.Address = a Then Set c = Nothing
Loop
'Transférer les données
With Worksheets("Perso")
'Nom
[A9].Value = ListBox2.List(ListBox2.ListIndex, 0)
'Prénom
[B9].Value = ListBox2.List(ListBox2.ListIndex, 1)
If Not c Is Nothing Then
'Date naissance
[A12].NumberFormat = "dd/mm/yyyy"
[A12].Value = c.Offset(0, 2)
'Commune
[B12].Value = c.Offset(0, 3)
'Dpt
[C12].Value = c.Offset(0, 4)
'Adresse
[A15].Value = c.Offset(0, 9)
'Complément
[B15].Value = c.Offset(0, 10)
'CP
[C15].Value = c.Offset(0, 11)
'Commune
[D15].Value = c.Offset(0, 12)
'Tel
[A18].Value = c.Offset(0, 5)
[B18].Value = c.Offset(0, 6)
End If
End With
Ecrire
Application.ScreenUpdating = True
End Sub


14 réponses

Messages postés
13114
Date d'inscription
mercredi 16 janvier 2013
Statut
Membre
Dernière intervention
14 octobre 2021
2 263
Bonjour

1) Chez moi le code a l'air de renvoyer les bonnes valeurs, peux tu donner un exemple ?

2) Mais surtout pourquoi s'embêter avec une macro alors qu'une simple liste déroulante pour le choix et des formules RECHERCHEV dans les cellules suffiraient !

Cdlmnt
Via
Messages postés
374
Date d'inscription
jeudi 11 août 2016
Statut
Membre
Dernière intervention
13 janvier 2020
14
re
Merci de me venir encore en aide
Sélectionne nom CCC3 prénom C3 puis CCC3 prénom C4
idem pour FFF6
Messages postés
13114
Date d'inscription
mercredi 16 janvier 2013
Statut
Membre
Dernière intervention
14 octobre 2021
2 263
Ton fichier avec macro modifiée :
https://www.cjoint.com/c/GHAkKUOzVW6

La méthode Find retrouve le 1er nom choisi mais lorsqu'il y a plusieurs personnes du même nom elle s'arrête toujours sur le premier

Mais en fait elle est inutile puisque la liste de choix est fondée sur la base, donc le 3eme choix est le 3eme de la base, ce qui donne sa ligne dans la matrice en rajoutant 2 au ListIndex

mais je reste persuadé qu'une liste déroulante dan sla feuille et des RECHERCHEV est plus simple et sans source de bug !

Cdlmnt
Via
Messages postés
374
Date d'inscription
jeudi 11 août 2016
Statut
Membre
Dernière intervention
13 janvier 2020
14
Désolé via, mais ça ne fonctionne pas chez moi
Messages postés
13114
Date d'inscription
mercredi 16 janvier 2013
Statut
Membre
Dernière intervention
14 octobre 2021
2 263
Re

Je ne comprends pas le fichier fonctionnait mais une fois fermé et réouvert l'UF ne veut pas s'afficher

Voici le code tel que l'ai modifié :
Sub Valider_Click() 'OK
     Application.ScreenUpdating = False
'Transfére des données ListBox dans la Feuille Perso
Application.ScreenUpdating = False
Dim f As Worksheet
Dim R As Range
Dim c As Range
Dim a As String
Dim l As Long

    If IsNull(ListBox2.Value) Then MsgBox "Vous devez effectuer une selection !", vbCritical + vbOKOnly, " Aucun contact sélectionné": Exit Sub

  'Chercher le nom et le prénom dans la base de données
  With Worksheets("Base")
     Set R = .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
  End With
  Set c = R.Find(What:=ListBox2.Value, LookIn:=xlValues, lookat:=xlWhole)
    'If Not c Is Nothing Then a = c.Address
   
   
   'N° de la ligne dans Base (=rang de l'item choisi dans Combobox +2)
   l = ListBox2.ListIndex + 2

    
    'Do While Not c Is Nothing
  'Vérifier le prénom
   'If c.Offset(0, 1).Value = ListBox2.List(ListBox2.ListIndex, 1) Then Exit Do
   ' Set c = R.FindNext
   ' If c.Address = a Then Set c = Nothing
    'Loop
  'Transférer les données
  With Worksheets("Perso")
  'Nom
  [A9].Value = ListBox2.List(ListBox2.ListIndex, 0)
  'Prénom
  [B9].Value = ListBox2.List(ListBox2.ListIndex, 1)
    If Not c Is Nothing Then
  'Date naissance
  [A12].NumberFormat = "dd/mm/yyyy"
  [A12].Value = Sheets("Base").Range("C" & l)
  'Commune
  [B12].Value = Sheets("Base").Range("D" & l)
  'Dpt
  [C12].Value = Sheets("Base").Range("E" & l)
  'Adresse
  [A15].Value = Sheets("Base").Range("j" & l)
  'Complément
  [B15].Value = Sheets("Base").Range("k" & l)
  'CP
  [C15].Value = Sheets("Base").Range("l" & l)
  'Commune
  [D15].Value = Sheets("Base").Range("m" & l)
  'Tel
  [A18].Value = Sheets("Base").Range("F" & l)
  [B18].Value = Sheets("Base").Range("G" & l)
  End If
  End With
  Ecrire
Application.ScreenUpdating = True
End Sub

Sub Ecrire() 'OK
Application.ScreenUpdating = False
'    Sheets("EC").Select
    [B1] = "ASSOCIATION AIDE PERSONNES"
    [B2] = "en DIFFICULTES"
    [B1:B2].Select
    Selection.Font.Bold = True
       With Selection.Font
            .Name = "Times New Roman"
            .Size = 16
        End With
    [B1:E2].Select
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
    End With
    
    [B5] = "Renseignements concernant :"
    [B5].Select
    Selection.Font.Bold = True
    
       With Selection.Font
        .Name = "Times New Roman"
        .Size = 14
       End With

     [B5].Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .ReadingOrder = xlContext
        End With
        
'        [B5:E5].Select
    With Selection
        .HorizontalAlignment = xlCenterAcrossSelection
        .VerticalAlignment = xlCenter
    End With
        
      [A8] = "Nom :"
      [B8] = "Prénom :"
    [A11] = "Né(e) le :"
    [B11] = "Commune :"
    [C11] = "Dpt ou CP :"
    [A14] = "Demeurant :"
    [B14] = "Complément adresse :"
    [C14] = "CP :"
    [D14] = "Commune :"
    [A17] = "Téléphone Fixe :"
    [B17] = "Téléphone Portable :"
    
    [A8:B8,A11:C11,A14:D14,A17:B17].Select
    With Selection.Font
        .Name = "Times New Roman"
        .Size = 8
    End With
    Selection.Font.Italic = True
      [a1].Select
Application.ScreenUpdating = True
End Sub


Cdlmnt
Via
Messages postés
374
Date d'inscription
jeudi 11 août 2016
Statut
Membre
Dernière intervention
13 janvier 2020
14
re,
j'ai un bug ici sur la ligne If IsNull :
Dim f As Worksheet
Dim R As Range
Dim c As Range
Dim a As String
Dim l As Long

If IsNull(ListBox2.Value) Then MsgBox "Vous devez effectuer une selection !", vbCritical + vbOKOnly, " Aucun contact sélectionné": Exit Sub
Messages postés
13114
Date d'inscription
mercredi 16 janvier 2013
Statut
Membre
Dernière intervention
14 octobre 2021
2 263
Re,

Pourtant je n'ai pas touché à cette ligne !
Essaye de remplacer IsNull(ListBox2.Value) par ListBox2.Value=""

Je me répéte mais des formules RECHERCEV ou INDEX EQUIV sans macro seraient plus efficaces
Et tu gardes la macro pour imprimer la fiche

"L'imagination est plus importante que le savoir."    A. Einstein
Messages postés
374
Date d'inscription
jeudi 11 août 2016
Statut
Membre
Dernière intervention
13 janvier 2020
14
re,
Bonsoir via55,
Je te remercie pour ta patience. C'est OK pour moi maintenant.
Messages postés
374
Date d'inscription
jeudi 11 août 2016
Statut
Membre
Dernière intervention
13 janvier 2020
14
re,
Décidément il y a un problème incompréhensible ça fonctionne parfaitement une fois de temps en temps.
Je vais écouter ta sagesse quand tu me dis :
la RECHERCEV ou INDEX EQUIV sans macro seraient plus efficaces
Mais je ne vois pas comment faire car RECHERCHEV ne peut prendre qu'une cellule.
Je compte donc sur toi.
En te remerciant de tout mon cœur.
Messages postés
13114
Date d'inscription
mercredi 16 janvier 2013
Statut
Membre
Dernière intervention
14 octobre 2021
2 263
Voilà ton fichier modifié

https://mon-partage.fr/f/EZ4rd9ok/

1) Nouvelle liste crée en colonne X de Base pour concaténer Nom Prenom. La plage de la colonne X est nommée de manière dynamique avec DECALER de manière à se rallonger au fur et à mesure que tu rajoutes des noms dans la base. Elle es nommée Liste pour pouvoir être utilisée dans la menu déroulant de Perso
Tu peux masquer cette colonne X si tu veux

2) Les formules INDEX EQUIV dans Perso renvoient les données situées sur la même ligne que la concaténation nom prénom chois dans la liste déroulante

Et voilà plus besoin de macro

Cdlmnt
Via
Messages postés
374
Date d'inscription
jeudi 11 août 2016
Statut
Membre
Dernière intervention
13 janvier 2020
14
re,
Tous mes remerciements Via, c'est vraiment sympa de ta part.
Je te souhaite le meilleur.
Jean
Messages postés
374
Date d'inscription
jeudi 11 août 2016
Statut
Membre
Dernière intervention
13 janvier 2020
14
Bonjour via55
Est-il possible de lancer une macro dès qu'un nom figure en A9 sachant que dans cette même cellule il y a cette formule :
en A9
=SI(ESTERREUR(INDEX(Base!A:A;EQUIV(EC!$F$5;Base!$X:$X;0)));"";INDEX(Base!A:A;EQUIV(EC!$F$5;Base!$X:$X;0)))

En te remerciant
Messages postés
13114
Date d'inscription
mercredi 16 janvier 2013
Statut
Membre
Dernière intervention
14 octobre 2021
2 263
Bonjour jean

En A9 non puisque comme tu le dis il ya une formule
Mais cela peut se faire à tout changement du choix en E5
Macro à mettre dans le worksheet de la feuille PErso
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E5")) Is Nothing Then 'mettre après then le nom de la macro à executer
End Sub


Cdlmnt
Via
Messages postés
374
Date d'inscription
jeudi 11 août 2016
Statut
Membre
Dernière intervention
13 janvier 2020
14
Merci via c'est tout bon