Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum. Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !

LISTE DES EMAILS, NUMÉRO DE TÉLÉPHONNES DES TRAVAILLEURS


Information sur la source

Catégorie :VBA Classé sous : listbox, entreprise, agent, formulaire, tri Niveau : Débutant Date de création : 29/05/2008 Date de mise à jour : 13/06/2008 08:49:13 Vu / téléchargé: 4 461 / 309

Note :
5 / 10 - par 1 personne
5,00 / 10

  • 1

  • 2

  • 3

  • 4

  • 5

  • 6

  • 7

  • 8

  • 9

  • 10

Commentaire sur cette source (5)
Ajouter un commentaire et/ou une note

Description

Cliquez pour voir la capture en taille normale
Cette source propose une manière simple de rechecher le numéro de telephone fixe ou mobile d'un collegue dans une entreprise, elle faite en VBA et utilise les formulaires d'Excel, Lisbox et conbobox avec possibilité d'ajouter, modifier ou supprimer un enrégistrement.
 

Source

  • Private Sub fermer_Click()
  • With ActiveWorkbook
  • .RunAutoMacros xlAutoClose
  • .Close
  • End With
  • End Sub
  • Private Sub Label_Rt_Menu_Click()
  • Unload Me
  • us1.Show modeless
  • End Sub
  • Private Sub OptionCell_Click()
  • filtre
  • End Sub
  • Private Sub OptionEmail_Click()
  • filtre
  • End Sub
  • Private Sub OptionExt_Click()
  • filtre
  • End Sub
  • Private Sub UserForm_initialize()
  • Worksheets("Famille").Activate
  • [b3:i1000].Sort key1:=[b3] ' Tri la BD
  • ' Me.ChoixNom.List = Application.Transpose(Range([b3], [B65000].End(xlUp)))
  • End Sub
  • Private Sub nom_Change()
  • filtre
  • End Sub
  • ''''''''''''''''''''''''''''''''''''''''''''''''''''''
  • Sub filtre()
  • If Me.Frame.Controls(0) = True Then
  • a = 1
  • ElseIf Me.Frame.Controls(1) = True Then
  • a = 2
  • Else: a = 3
  • End If
  • Select Case a
  • Case 1
  • Me.TextBox5 = "Extention Number"
  • Set c = Range("b:b").Find("*" & Me.nom & "*", LookIn:=xlValues)
  • If Not c Is Nothing Then
  • premier = c.Address
  • i = 0
  • Me.ListBoxdon.Clear
  • Do
  • Me.ListBoxdon.AddItem
  • Me.ListBoxdon.List(i, 0) = c.Offset(0, 0).Value ' code
  • Me.ListBoxdon.List(i, 1) = c.Offset(0, 1).Value ' Nom
  • Me.ListBoxdon.List(i, 2) = c.Offset(0, 2).Value ' Fonction
  • Me.ListBoxdon.List(i, 3) = c.Offset(0, 4).Value ' Adresse
  • Set c = Range("b:b").FindNext(c)
  • i = i + 1
  • Loop While Not c Is Nothing And c.Address <> premier
  • End If
  • Case 2
  • Me.TextBox5 = "Cell Number"
  • Set c = Range("b:b").Find("*" & Me.nom & "*", LookIn:=xlValues)
  • If Not c Is Nothing Then
  • premier = c.Address
  • i = 0
  • Me.ListBoxdon.Clear
  • Do
  • Me.ListBoxdon.AddItem
  • Me.ListBoxdon.List(i, 0) = c.Offset(0, 0).Value ' code
  • Me.ListBoxdon.List(i, 1) = c.Offset(0, 1).Value ' Nom
  • Me.ListBoxdon.List(i, 2) = c.Offset(0, 2).Value ' Fonction
  • Me.ListBoxdon.List(i, 3) = c.Offset(0, 5).Value ' Adresse
  • Set c = Range("b:b").FindNext(c)
  • i = i + 1
  • Loop While Not c Is Nothing And c.Address <> premier
  • End If
  • Case Else
  • Me.TextBox5 = "E-Mail "
  • Set c = Range("b:b").Find("*" & Me.nom & "*", LookIn:=xlValues)
  • If Not c Is Nothing Then
  • premier = c.Address
  • i = 0
  • Me.ListBoxdon.Clear
  • Do
  • Me.ListBoxdon.AddItem
  • Me.ListBoxdon.List(i, 0) = c.Offset(0, 0).Value ' code
  • Me.ListBoxdon.List(i, 1) = c.Offset(0, 1).Value ' Nom
  • Me.ListBoxdon.List(i, 2) = c.Offset(0, 2).Value ' Fonction
  • Me.ListBoxdon.List(i, 3) = c.Offset(0, 6).Value ' Adresse
  • Set c = Range("b:b").FindNext(c)
  • i = i + 1
  • Loop While Not c Is Nothing And c.Address <> premier
  • End If
  • End Select
  • End Sub
  • Private Sub UserForm_Terminate()
  • With ActiveWorkbook
  • .RunAutoMacros xlAutoClose
  • .Close
  • End With
  • End Sub
Private Sub fermer_Click()
With ActiveWorkbook
    .RunAutoMacros xlAutoClose
    .Close
End With
End Sub

Private Sub Label_Rt_Menu_Click()
Unload Me
us1.Show modeless
End Sub

Private Sub OptionCell_Click()
filtre
End Sub

Private Sub OptionEmail_Click()
filtre
End Sub

Private Sub OptionExt_Click()
filtre
End Sub

    Private Sub UserForm_initialize()
    Worksheets("Famille").Activate
       [b3:i1000].Sort key1:=[b3]           ' Tri la BD
     '  Me.ChoixNom.List = Application.Transpose(Range([b3], [B65000].End(xlUp)))
     End Sub
 Private Sub nom_Change()
    filtre
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub filtre()


  If Me.Frame.Controls(0) = True Then
      a = 1
      ElseIf Me.Frame.Controls(1) = True Then
      a = 2
      Else: a = 3
     End If
Select Case a
 Case 1
 Me.TextBox5 = "Extention Number"
     Set c = Range("b:b").Find("*" & Me.nom & "*", LookIn:=xlValues)
        If Not c Is Nothing Then
        premier = c.Address
            
        i = 0
        Me.ListBoxdon.Clear
     
      
        Do
      
        Me.ListBoxdon.AddItem
                  
                  Me.ListBoxdon.List(i, 0) = c.Offset(0, 0).Value ' code
                  Me.ListBoxdon.List(i, 1) = c.Offset(0, 1).Value ' Nom
                  Me.ListBoxdon.List(i, 2) = c.Offset(0, 2).Value ' Fonction
                  
                  Me.ListBoxdon.List(i, 3) = c.Offset(0, 4).Value ' Adresse
                  
                  
        Set c = Range("b:b").FindNext(c)
        i = i + 1
        Loop While Not c Is Nothing And c.Address <> premier
      
        End If
    
  Case 2
  Me.TextBox5 = "Cell Number"
     Set c = Range("b:b").Find("*" & Me.nom & "*", LookIn:=xlValues)
        If Not c Is Nothing Then
        premier = c.Address
       
              
        i = 0
        Me.ListBoxdon.Clear
     
      
        Do
      
        Me.ListBoxdon.AddItem
                  
                  Me.ListBoxdon.List(i, 0) = c.Offset(0, 0).Value ' code
                  Me.ListBoxdon.List(i, 1) = c.Offset(0, 1).Value ' Nom
                  Me.ListBoxdon.List(i, 2) = c.Offset(0, 2).Value ' Fonction
                  
                  Me.ListBoxdon.List(i, 3) = c.Offset(0, 5).Value ' Adresse
                  
                  
    Set c = Range("b:b").FindNext(c)
        i = i + 1
      Loop While Not c Is Nothing And c.Address <> premier
      
    End If
   Case Else
   Me.TextBox5 = "E-Mail "
     Set c = Range("b:b").Find("*" & Me.nom & "*", LookIn:=xlValues)
    If Not c Is Nothing Then
      premier = c.Address
       
              
      i = 0
      Me.ListBoxdon.Clear
     
      
      Do
      
      Me.ListBoxdon.AddItem
                  
                  Me.ListBoxdon.List(i, 0) = c.Offset(0, 0).Value ' code
                  Me.ListBoxdon.List(i, 1) = c.Offset(0, 1).Value ' Nom
                  Me.ListBoxdon.List(i, 2) = c.Offset(0, 2).Value ' Fonction
                  
                  Me.ListBoxdon.List(i, 3) = c.Offset(0, 6).Value ' Adresse
                                    
    Set c = Range("b:b").FindNext(c)
        i = i + 1
      Loop While Not c Is Nothing And c.Address <> premier
      
    End If
    End Select
End Sub

Private Sub UserForm_Terminate()
With ActiveWorkbook
    .RunAutoMacros xlAutoClose
    .Close
End With
End Sub

Conclusion

Commencez par desactiver la securité des macro en excel, la suite sera facile
Mot de Passee pour la modification et l'ajout : "nizebel"
 

Fichier Zip

Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !
  • contact list1.xlsTélécharger ce fichier [Réservé aux membres club]555 520 octets

Télécharger le zip

Historique

30 mai 2008 07:55:24 :
Changement de la Capture
30 mai 2008 07:56:54 :
Changement de la Capture
30 mai 2008 08:00:29 :
Chengement de la Capture
30 mai 2008 09:34:33 :
Pris en compte du conseil de bigfish_le vrai Modification de Sub Filtre()
03 juin 2008 11:35:58 :
Code
03 juin 2008 11:37:48 :
code
13 juin 2008 08:49:13 :
Modification

Commentaires et avis

signaler à un administrateur
Commentaire de bigfish_le vrai le 30/05/2008 00:01:50

Salut,

ben y a beaucoup a dire :
- code tres peut commenté
- apprend a boucler sur des controles pour simplifier le code
- apprend a te servir de la fonction Select case
- les variables sont pas suffisament declarées d'ailleur pour etre sur de toute les declareés ajoute Option Exlicit en debut de module ou du code d'un objet (feuille, formulaire...)
- pas de bouton pour fermer les formulaires on est obligé d'utiliser la croix
- pas mal de code qui ne sert a rien
- etc

un exemple de simplification :

Pour commencer ton code :

Sub filtre()


  If Me.Frame.Controls(0) = True Then
      A = 1
      ElseIf Me.Frame.Controls(1) = True Then
      A = 2
      Else: A = 3
     End If
Select Case A
Case 1
Me.TextBox5 = "Tel Fixe / Ext Number"
     Set c = Range("b:b").Find("*" & Me.nom & "*", LookIn:=xlValues)
        If Not c Is Nothing Then
        premier = c.Address
            
        i = 0
        Me.ListBoxdon.Clear
    
      
        Do
      
        Me.ListBoxdon.AddItem
                  
                  Me.ListBoxdon.List(i, 0) = c.Offset(0, 0).Value ' code
                  Me.ListBoxdon.List(i, 1) = c.Offset(0, 1).Value ' Nom
                  Me.ListBoxdon.List(i, 2) = c.Offset(0, 2).Value ' Nom
                  Me.ListBoxdon.List(i, 3) = c.Offset(0, 4).Value ' Fonction
                  
                  
                  
                  
        Set c = Range("b:b").FindNext(c)
        i = i + 1
        f = i - 1
        Loop While Not c Is Nothing And c.Address <> premier
      
        End If
    
  Case 2
  Me.TextBox5 = "Cell Number"
     Set c = Range("b:b").Find("*" & Me.nom & "*", LookIn:=xlValues)
        If Not c Is Nothing Then
        premier = c.Address
      
              
        i = 0
        Me.ListBoxdon.Clear
    
      
        Do
      
        Me.ListBoxdon.AddItem
                  
                  Me.ListBoxdon.List(i, 0) = c.Offset(0, 0).Value ' code
                  Me.ListBoxdon.List(i, 1) = c.Offset(0, 1).Value ' Nom
                  Me.ListBoxdon.List(i, 2) = c.Offset(0, 2).Value ' Nom
                  Me.ListBoxdon.List(i, 3) = c.Offset(0, 5).Value ' Fonction
                  
                  
                  
                  
    Set c = Range("b:b").FindNext(c)
        i = i + 1
      Loop While Not c Is Nothing And c.Address <> premier
      
    End If
   Case Else
   Me.TextBox5 = "E-Mail Chemaf"
     Set c = Range("b:b").Find("*" & Me.nom & "*", LookIn:=xlValues)
    If Not c Is Nothing Then
      premier = c.Address
      
              
      i = 0
      Me.ListBoxdon.Clear
    
      
      Do
      
      Me.ListBoxdon.AddItem
                  
                  Me.ListBoxdon.List(i, 0) = c.Offset(0, 0).Value ' code
                  Me.ListBoxdon.List(i, 1) = c.Offset(0, 1).Value ' Nom
                  Me.ListBoxdon.List(i, 2) = c.Offset(0, 2).Value ' Nom
                  Me.ListBoxdon.List(i, 3) = c.Offset(0, 6).Value ' Fonction
                  
                  
    Set c = Range("b:b").FindNext(c)
        i = i + 1
      Loop While Not c Is Nothing And c.Address <> premier
      
    End If
    End Select
End Sub

Puis la version simplifié :

Sub filtre()
    Dim MaColonne As Long, c As Range, i As Long
    If Me.Frame.Controls(0) = True Then
        Me.TextBox5 = "Tel Fixe / Ext Number"
        MaColonne = 4
    ElseIf Me.Frame.Controls(1) = True Then
        Me.TextBox5 = "Cell Number"
        MaColonne = 5
    Else
        Me.TextBox5 = "E-Mail Chemaf"
        MaColonne = 6
    End If
    Set c = Range("b:b").Find("*" & Me.nom & "*", LookIn:=xlValues)
    If Not c Is Nothing Then
        premier = c.Address
        i = 0
        Me.ListBoxdon.Clear
        Do
            Me.ListBoxdon.AddItem
            Me.ListBoxdon.List(i, 0) = c.Offset(0, 0).Value ' code
            Me.ListBoxdon.List(i, 1) = c.Offset(0, 1).Value ' Nom
            Me.ListBoxdon.List(i, 2) = c.Offset(0, 2).Value ' Nom
            Me.ListBoxdon.List(i, 3) = c.Offset(0, MaColonne).Value ' Fonction
            Set c = Range("b:b").FindNext(c)
            i = i + 1
        Loop While Not c Is Nothing And c.Address <> premier
    End If
End Sub

j'ai pas trop reflechi mais j'entre vois encore plus simple

Honnetement ca ne vaut pas une bonne note mais pour t'encourager je ne la donne pas

^^

signaler à un administrateur
Commentaire de ferdhy le 30/05/2008 09:40:28

Merci Bcp pour le conseil
j'ai besoin d'aide des personnes comme vous pour améliorer.

Les codes qui ne servent à rien, c'etait pour une autre fonctionalité que j'ai du supprimer, merci

signaler à un administrateur
Commentaire de ferdhy le 02/06/2008 09:26:26

Encore plus de commentaires svp!!!

signaler à un administrateur
Commentaire de mistygirl le 06/06/2008 15:25:49 5/10

C'est quelle partie du code qui permet de modifier un enregistrement et comment ça fonctionne? Désolée si c'est une question bête mais c'est vrai que c'est pas beaucoup commenté et je débute (et j'ai justement besoin de modifier des enregistrements).

signaler à un administrateur
Commentaire de ferdhy le 13/06/2008 08:45:06

Private Sub UserForm_initialize()
Worksheets("Famille").Activate
   [A3:h1000].Sort key1:=[b3]           ' Tri la BD
   Me.ChoixNom.List = Application.Transpose(Range([b3], [b65000].End(xlUp)))
   cfs.Visible = False
End Sub
Private Sub ChoixNom_Change()
   [b3].Offset(ChoixNom.ListIndex, 0).Select 'on selectione la cellule de l'element
                                             'du combobox
     '***********trnasfert des element de la feuille vers le formulaire***********
     Me.nom = ActiveCell
    
     Me.Fonction = ActiveCell.Offset(0, 1)
     Me.Service = ActiveCell.Offset(0, 2)
     Me.Location = ActiveCell.Offset(0, 3)
     Me.Extnum = ActiveCell.Offset(0, 4)
     Me.celNum = ActiveCell.Offset(0, 5)
     Me.Email = ActiveCell.Offset(0, 6)
    
  
  
    
End Sub
Private Sub b_validation_Click() '************** Valider la Modification
   '--- Contrôles
   If Me.nom = "" Then
      MsgBox "Saisir un nom!"
      Me.nom.SetFocus
      Exit Sub
   End If
  
   '--- Positionnement dans la base
   ActiveCell.Offset(0, -1).Select
   '--- Transfert Formulaire dans BD du fromulaire à la feuille d'excel
   ActiveCell.Offset(0, 1).Value = Me.nom
   ActiveCell.Offset(0, 2).Value = Me.Fonction
   ActiveCell.Offset(0, 3).Value = Me.Service
   ActiveCell.Offset(0, 4).Value = Me.Location
   ActiveCell.Offset(0, 5).Value = Me.Extnum
   ActiveCell.Offset(0, 6).Value = Me.celNum
   ActiveCell.Offset(0, 7).Value = Me.Email
  
   nettoie
   Unload Me
End Sub
Sub nettoie()  ' *****************Vider les textbox après modification
Me.nom = ""
   Me.Fonction = ""
   Me.Service = ""
   Me.Location = ""
   Me.Extnum = ""
   Me.celNum = ""
   Me.Email = ""
End Sub

Ajouter un commentaire

Discussions en rapport avec ce code source dans le forum

tri de listbox [ par Oups ] qu'elle et la methode de trie la plus approprié dans d'une listbox qui charge des enregistrements ayant un chiffre devant chaque lignes ? quand je cha listbox vba [ par anfo ] Bonjour!Je travaille avec Access. J'ai mis sur mon formulaire, un contrôle ActiveX listBox. Lorsque je met mon formulaire en mode formulaire, Il y a u listbox [ par anfo ] Bonjour!Je travaille avec Access. J'ai mis sur mon formulaire, un contrôle ActiveX listBox. Lorsque je met mon formulaire en mode formulaire, Il y a u access: selection auto d'un item ds listbox [ par SamLJ ] Je vais dc vs expliquer mon pb soyez attentif :-)g une base de donnée composée de 3 tables:"logiciel","utilisateur", et "logiciel-utilisateur"( cette répérer l'évenement Tri (A-Z) ou Tri (Z-A) dans un formulaire access [ par tofoli ] Bonjour,Je chercher a répérer l'évenement Tri (A-Z) ou Tri (Z-A) dans un formulaire access ouvert en mode feuille de données.Je ne trouve rien dans la tri d'une ListBox [ par dao85 ] Bonjour à tous et bonne semainePas trop dur le lundi???Moi j'ai un petit souci et je ne sais pas si il éxiste une solution:Voila :Je remplis une listB Tri dans une ListBox [ par xabi62 ] Est-ce qu'on peut faire un tri par ordre alphabétique de tous les éléments contenu dans une ListBox.Si oui comment faut-il faire..?????Merci A+xabi info dans BDD [ par noob ] bonjour,voila mon probleme. J'ai un formulaire de demande d'info (nom, prenom, tel .....) que l'utilisateur rempli. Puis il valide et se retrouve deva pbl tri listbox [ par kdavtodie ] Bonjour,j ai un ptit souci sur l affichage d une listbox qui est le résultat d une comparaison avec une autre listbox, donc ces deux la on une proprié Bug Clic Formulaire Access [ par ozar ] Bonjour,J'ai un formulaire Access avec plusieurs listbox, Combo et text . Lorsque je clic sur un listbox, il arrive qu'après je ne puisse plus dutout


Nos sponsors

Sondage...

CalendriCode

Téléchargements

Logiciels à télécharger sur le même thème :



Développement réalisé par Nicolas SOREL (Nix) avec l'aide de : Cyril DURAND et Emmanuel BAÏSE, Merci à Vincent pour ses précieux conseils
CodeS-SourceS.com© Toute reproduction même partielle est interdite sauf accord écrit du Webmaster
CodeS-SourceS.com© est une marque déposée tous droits réservés
Temps d'éxécution de la page : 0,437 sec

Google Coop CodeS-SourceS Google Coop CodeS-SourceS


Certaines images présentes sur le site (notament certains avatars) sont issues des collections IconShock, donc si vous souhaitez utiliser ces icons vous devez les acheter, ne les copiez pas et ne utilisez pas dans vos sites et applications sans les avoir commandé.