Forum |  HardWare.fr | News | Articles | PC | Prix | S'identifier | S'inscrire | Shop Recherche
1862 connectés 

  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  VBA Excel Liste des numéros de téléphone d'un service

 



 Mot :   Pseudo :  
 
Bas de page
Auteur Sujet :

VBA Excel Liste des numéros de téléphone d'un service

n°2226898
BrisChri
Since 1956
Posté le 01-05-2014 à 13:12:41  profilanswer
 

Salut,
Tout, ou presque, est dans le titre... j'aimerais créer un classeur Excel avec les numéros de téléphone des collègues du service.
Évidemment, si tout était dans le titre, il suffirait d'ouvrir un nouveau classeur et d'entrer ses données.
Heureusement, il y a le presque.

  • Toutes les données sur une page.

Plusieurs colonnes donc. Actuellement, le service n'étant pas fortement peuplé, il y a 3 colonnes de données.

  • Plusieurs pages présentées de la même façon mais ayant les donnés triées différemment.

Nom / Prénom / bureau ; Prénom / Nom / bureau; la même chose mais d'abord par rôle linguistique.
 

  • Classeur des données :

Feuille 1 (Menu) :
L'interface avec nouveau nom, nouveau fax, modification (nom), Création du classeur résultat.
 
Feuille 2 (Liste) :
Avec les données entrées : Nom, Prénom, RL (rôle linguistique), Bureau, Tel
Avec des données de travail : NomNormalisé, PrénomNormalisé, CodeDonnée.  
Avec des données pour les tris : nom+prénom et prénom+nom (normalisés)
 

  • Classeur résultat :

4 feuilles, 4 colonnes
(NOM Prénom / RL / bureau / Tel) * 3, puisqu'il y a place pour mettre 3 paquets de données sur une ligne.
 
J'y ajoute une 5ème feuille (Sauvetage) qui devrait être invisible :
J'espère trouver le moyen d'installer, sur chaque cellule de "nom" un format conditionnel par VBA
Si il y a une différence entre le contenu de la cellule "nom" et la cellule correspondante  "sauvetage", la fonte doit être rouge et le caractère bold.
Je n'ai pas encore trouvé comment faire ni même si c'est possible.
 
Le but ?
Utiliser le classeur créé pour noter les changements à planifier pour l'édition suivante (suite à un changement de bureau par ex.)


Message édité par BrisChri le 09-05-2014 à 19:29:34

---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
mood
Publicité
Posté le 01-05-2014 à 13:12:41  profilanswer
 

n°2226899
BrisChri
Since 1956
Posté le 01-05-2014 à 13:13:00  profilanswer
 

Normaliser Noms et Prénoms.
VAN DEN BRANDE, VANDEN BRANDE, VANDENBRANDE sont des noms que l'on trouve par ici. Dans une liste, ces noms sont séparés alors que, dans une recherche, on aurait tendance à penser les trouver à la suite l'un de l'autre.
On a une situation semblable en français avec de et De, le tri les sépare, le de passant même avant Daniel...
La normalisation du prénom permet, quant à elle, de réunir Andre et André.
 
La fonction de normalisation est assez simple.
 

  • Passer la Chaine de caractères en minuscules
  • Supprimer les caractères spéciaux qui entrent dans les nomn : apostrophe, trait d'union et espace
  • Remplacer les caractères accentués par l'équivalent sans accent. Ne pas oublier le ç.


Code :
  1. Function Normaliser(ByVal Chaine$)
  2. Const Avec = "àáâãäåéêëèìíîïðòóôõöùúûüç"
  3. Const Sans = "aaaaaaeeeeiiiioooooouuuuc"
  4. Const Speciaux = "'- "
  5. Dim i As Byte
  6. Chaine = LCase(Chaine)
  7.     For i = 1 To Len(Speciaux)
  8.         Chaine = Replace(Chaine, Mid(Speciaux, i, 1), "" )
  9.     Next i
  10.     For i = 1 To Len(Avec)
  11.         Chaine = Replace(Chaine, Mid(Avec, i, 1), Mid(Sans, i, 1))
  12.     Next i
  13. Normaliser = Chaine
  14. End Function


 
Il reste à enregistrer le résultat dans la bonne colonne.
Pour avoir facile à retenir les numéros de colonne, j'utilise des constantes.
Public Const ncNom As Long = 1
Avec 12 colonnes, utiliser ncNom ou ncTel est plus clair que 1 ou ?? j'ai déjà oublié.


Message édité par BrisChri le 09-05-2014 à 19:37:50

---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
n°2226971
BrisChri
Since 1956
Posté le 02-05-2014 à 10:04:34  profilanswer
 

https://farm8.staticflickr.com/7348/14146222325_cb44b4215f_n.jpg
Clipboard01 par BrisChri, sur Flickr
 
https://farm6.staticflickr.com/5499/14123043276_6a69415ea4.jpg
Clipboard02 par BrisChri, sur Flickr
 
Rien de bien compliqué, il suffit de ne pas oublier de gérer le bilinguisme et de charger les textes depuis la feuille"Textes".


Message édité par BrisChri le 09-05-2014 à 19:52:05

---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
n°2227134
BrisChri
Since 1956
Posté le 04-05-2014 à 22:10:29  profilanswer
 

La création du nouveau classeur est assez simple, elle aussi.
Workbooks.Add(1)
Nommer la feuille et la remplir.

Code :
  1. '   créer le fichier
  2.     FraListesAttendre.Caption = "création du fichier"
  3.     Set wbTo = Workbooks.Add(1)
  4.    
  5.     '   créer et remplir la page 1 : Noms
  6.     FraListesAttendre.Caption = "création de la page 1"
  7.     TrierSurNom
  8.     Set wsTo = wbTo.Sheets(1)
  9.     ActiveSheet.Name = "Noms"
  10.     Call EcrirePage(ncNomPrenom)


 
Un problème, le message (FraListesAttendre.Caption = "création de la page 1" ) ne s'affiche pas.
Si quelqu'un sait comment il faut faire pour que le UserForm s'affiche avant de commencer (je l'ai mis en non modal, est-ce correct ?)
 
Créer les pages suivantes :

Code :
  1. '   créer et remplir la page 2 : Prénoms
  2.     FraListesAttendre.Caption = "création de la page 2"
  3.     TrierSurPrenom
  4.     wbTo.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Prénoms"
  5.     Set wsTo = wbTo.Sheets(2)
  6.     Call EcrirePage(ncPrenomNom)


 
La feuille 1 est triée sur nom, la liste sort en affichant la colonne NomPrenom, EcrirePage ne fait rien d'autre qu'écrire, il n'y a aucun tri.
 
Créer la dernière feuille.
Si le fichier tient compte de la langue, il y a 2 feuille triées sur RL / NomPrénom (ou PrénomNom). Si le fichier est uniligue, il n'y a pas de raison de créer ce 2 feuilles, résultat, il faut compter le nombre de feuilles existantes pour ajouter la dernière qui sera la 3ème ou la 5ème du classeur.

Code :
  1. '   créer et remplir la dernière page
  2.     FraListesAttendre.Caption = "création de la dernière page"
  3.     TrierSurNom
  4.     wbTo.Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = "Sauvetage"
  5.     Set wsTo = wbTo.Sheets(Worksheets.Count)
  6.     Call EcrirePage(ncNomPrenom)


 
Avec, pour EcrirePage :

Code :
  1. Sub EcrirePage(NomOuPrenom As Long)
  2.     '   écrire son titre
  3.     wsTo.Range("C3" ).Value = wsTextes.Range("A2" )
  4.     wsTo.Range("C4" ).Value = wsTextes.Range("A3" )
  5.     wsTo.Range("C5" ).Value = wsTextes.Range("A4" )
  6.     nLigneTitre = 5
  7.    
  8.     nLigneDonnee = nLigneTitre + 1
  9.     '   copier les données
  10.     k = 1
  11.     For i = 1 To 3
  12.         For j = 1 To tColOut(i)
  13.             k = k + 1
  14.             nCol = ((i - 1) * 5) + 3
  15.             wsTo.Cells(j + nLigneDonnee, nCol).Value = wsListe.Cells(k, ncBur)
  16.             wsTo.Cells(j + nLigneDonnee, nCol).HorizontalAlignment = xlCenter
  17.             wsTo.Cells(j + nLigneDonnee, nCol + 1).Value = wsListe.Cells(k, NomOuPrenom)
  18.             wsTo.Cells(j + nLigneDonnee, nCol + 2).Value = tLang(wsListe.Cells(k, ncRL))
  19.             wsTo.Cells(j + nLigneDonnee, nCol + 2).HorizontalAlignment = xlCenter
  20.             wsTo.Cells(j + nLigneDonnee, nCol + 3).Value = wsListe.Cells(k, ncTel)
  21.             wsTo.Cells(j + nLigneDonnee, nCol + 3).HorizontalAlignment = xlCenter
  22.             If wsListe.Cells(k, ncCode) = Personne Then
  23.                 wsTo.Cells(j + nLigneDonnee, nCol + 2).Interior.ColorIndex = tColorLang(wsListe.Cells(k, ncRL))
  24.             End If
  25.             If wsListe.Cells(k, ncCode) = Fax Then
  26.                 wsTo.Cells(j + nLigneDonnee, ((i - 1) * 5) + 4).Interior.ColorIndex = colorFax
  27.             End If
  28.             If wsListe.Cells(k, ncCode) = Salle Then
  29.                 wsTo.Cells(j + nLigneDonnee, ((i - 1) * 5) + 4).Interior.ColorIndex = colorSalle
  30.             End If
  31.         Next j
  32.     Next i
  33.     nLigneDonnee = nLigneDonnee + tColOut(1) + 1
  34.    
  35.     '   copier renseignements généraux
  36.     nLigneRens = 0
  37.     EcrireRens                  '   mettre en commentaire si pas utile
  38.     nLigneRens = nLigneDonnee + nLigneRens
  39.    
  40.     '   Aligner le titre
  41.     wsTo.Range("C3:P3" ).MergeCells = True
  42.     wsTo.Range("C4:P4" ).MergeCells = True
  43.     wsTo.Range("C5:P5" ).MergeCells = True
  44.     wsTo.Range("C3:P5" ).HorizontalAlignment = xlCenter
  45.    
  46.     '   Fonte Titre
  47.     'With wsTo.range("C3:P5" ).Font
  48.     '    .Name = "Tahoma"
  49.     'End With
  50.    
  51.     '   Fonte données
  52.     'With wsTo.range("C3:P5" ).Font
  53.     '    .Name = "Tahoma"
  54.     'End With
  55.    
  56.     '   Hauteur et Largeur des cellules
  57.     j = wsTextes.Range("A5" ).End(xlToRight).Column
  58.     For i = 1 To j
  59.         wsTo.Columns(i).ColumnWidth = wsTextes.Cells(5, i)
  60.     Next i
  61.     wsTo.Rows(1).RowHeight = wsTextes.Cells(6, 1)
  62.     wsTo.Rows(2).RowHeight = wsTextes.Cells(6, 1)
  63.     wsTo.Rows(nLigneTitre + 1).RowHeight = wsTextes.Cells(6, 1)
  64.     wsTo.Rows(nLigneDonnee).RowHeight = wsTextes.Cells(6, 1)
  65.     wsTo.Rows(nLigneRens).RowHeight = wsTextes.Cells(6, 1)
  66.    
  67.     '   encadrement
  68.     Call CadreListe(3, 3, nLigneTitre, 16)                          '   cadre titre
  69.     Call CadreListe(2 + nLigneTitre, 3, 6 + tColOut(1), 6)          '   colonne 1 des data
  70.     Call CadreListe(2 + nLigneTitre, 8, 6 + tColOut(2), 11)
  71.     Call CadreListe(2 + nLigneTitre, 13, 6 + tColOut(3), 16)
  72.     Call CadreListe(2, 2, nLigneRens, 17)                           '   autour de tout
  73.    
  74.     Call DemiCadreListe(2 + nLigneTitre, 3, 6 + tColOut(1), 6)      '   colonne 1 des data
  75.     Call DemiCadreListe(2 + nLigneTitre, 8, 6 + tColOut(2), 11)
  76.     Call DemiCadreListe(2 + nLigneTitre, 13, 6 + tColOut(3), 16)
  77.        
  78.    
  79.     '   Supprimer le quadrillage
  80.     ActiveWindow.DisplayGridlines = False
  81. End Sub


 
tColOut(n) contient le nombre de ligne à écrire dans la Colonne n (oui, aussi bizarre qu'il puisse paraître, le nom a un sens).
Il y a certainement un moyen mathématique de trouver le nombre de lignes.
Pour 10 données, je dois avoir 4.3.3.
10 / 3 donne 3 par colonne avec un reste de 1 qu'on ajoute à la première colonne.
11 lignes, 4.4.3
11 / 3 donne 3 avec un reste de 2, soit +1 dans 2 colonnes.
Ici, je me suis amusé à compter avant le travail. Ca ne sert pas à grand chose, sinon qu'avec cette méthode, il est possible d'automatiser en mettant le nombre de colonnes dans une variable...
Ce n'est utilisable que s'il y a peu de données, un calcul préalable est toujours préférable :o
Voici le code qui ralenti la macro...

Code :
  1. Sub PreparerPrt()
  2.     For i = 1 To 3
  3.         tColOut(i) = 0
  4.     Next i
  5.     i = 0
  6.     For j = 2 To nMaxLigne
  7.         i = i + 1
  8.         If i > 3 Then
  9.             i = 1
  10.         End If
  11.         tColOut(i) = tColOut(i) + 1
  12.     Next j
  13. End Sub


 
et, pour ceux qui se demandent à quoi servent les lignes

Code :
  1. '   copier renseignements généraux
  2.     nLigneRens = 0
  3.     EcrireRens                  '   mettre en commentaire si pas utile
  4.     nLigneRens = nLigneDonnee + nLigneRens


La réponse :
https://farm8.staticflickr.com/7363/13959749848_823c0eded3_n.jpg
Clipboard03 par BrisChri, sur Flickr
 
Il s'agit de (de, pas des :) ) renseignements généraux qui peuvent servir mais dont on ne se sert pas.


Message édité par BrisChri le 09-05-2014 à 20:21:05

---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
n°2227581
BrisChri
Since 1956
Posté le 08-05-2014 à 15:58:21  profilanswer
 

Il reste encore à faire...
 
Les renseignements généraux ne s'impriment pas si on n'utilise qu'une seule langue. Pas génant pour moi.
Il reste à écrire :

  • la création de "fax", la création de "salle de réunion" (bureau et tel, avec texte imposé, une seule ligne pour fax, 2 pour les salles si on travaille en 2 langues...)
  • la modification d'un nom.

La modification salle ou fax, ainsi que la suppression d'une ligne peut se faire directement sur la page "listes".
Sauf si quelqu'un veut bien s'y coller...


Message édité par BrisChri le 09-05-2014 à 20:29:05

---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
n°2227662
BrisChri
Since 1956
Posté le 09-05-2014 à 20:31:19  profilanswer
 

Voilà, c'est tout pour aujourd'hui.
Si quelqu'un est intéressé par le fichier, adresse mail en MP et j'envoie le truc en l'état (fini ou non, ça dépendra) sans aucune donnée.


---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
n°2227674
BrisChri
Since 1956
Posté le 09-05-2014 à 23:44:42  profilanswer
 

Quelqu'un pour aider à la modification des données des personnes ?
Je ne vois pas trop bien comment effectuer une recherche.
Code="p"
remplir une table pour charger un contrôle (combobox?)
Mais ensuite ?


Message édité par BrisChri le 09-05-2014 à 23:50:20

---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
n°2227691
Marc L
Posté le 10-05-2014 à 11:32:06  profilanswer
 

 
           Bonjour,
 
           sans tenants & aboutissants, voir du côté de la méthode  Find  par exemple …
 
           Sinon utiliser les fonctions de formules de feuilles de calculs - y a le choix ! - et une fois une formule au point,
           ce n'est vraiment pas difficile de la convertir en VBA …
 

n°2227696
BrisChri
Since 1956
Posté le 10-05-2014 à 13:51:35  profilanswer
 

DIM sRech As String
DIM rRech As Range
DIM ncRech As Long
 
Modifier les données d'une personne.
   Nom :
      sRech = Normaliser le nom entré  
      nLigne = 2
      ncRech = ncNomNorm (numéro de la colonne de recherche = numéro de la colonne qui contient le nom normalisé)
      Chercher
   Prénom :
      ncRech = ncPrenomNorm
 
 
   Sub Chercher()
      set rRech = wsListe.Range(Cells(nLigne, ncRech), Cells(nMaxLigne, ncRech).Find(What:=sRech
 
Si le nom n'est pas trouvé ?
Comment retrouver nLigne au départ de rRech ?


---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
n°2227700
BrisChri
Since 1956
Posté le 10-05-2014 à 14:29:20  profilanswer
 

Le fichier actuel : http://paf.im/F3Az9
 
 
Il faut entrer des données (le fichier est vide) avant de "créer listes".
 
"quitter le menu" ne ferme pas le fichier, ça permet de :
      modifier
            langue :  
                  "Textes", unprotect, A1, 1 pour FR, 2 pour NL
            titre :
                  "Textes, unprotect, A13 & A14
      contrôler "Liste"
      modifier "Liste"
                  "Liste", unprotect, sélectionner, supprimer ou modifier (num de tel ou de bureau), ne pas modifier nom et prénom, ils ne passent plus par la normalisation.
      voir le code
 
revenir à la page "Menu" relance le menu.
 
"fermer le fichier" ne ferme pas Excel.
 
 
édit
mod à faire dans le fichier fourni (dans module1) :
 
Sub EcrirePage(NomOuPrenom As Long)
...
      wsTo.Range("C5" ).Value = "-   " & Format(wsTextes.Range("A4", "dd-mm-yyyy" ) & "   -"
je viens de modifier le prg, la date qui apparaît dans le "menu" est la date de création du dernier fichier, j'ai oublié de modifier cette ligne-là
ça ne plante pas le prg, mais la date affiche dans le titre est difficilement compréhensible
 
Sub EcrireFichier()
      sFich = sRep & "TelService.xlsx"      
sinon il vous fait un fichier par jour


Message édité par BrisChri le 11-05-2014 à 18:50:54

---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
mood
Publicité
Posté le 10-05-2014 à 14:29:20  profilanswer
 

n°2227744
BrisChri
Since 1956
Posté le 11-05-2014 à 18:48:24  profilanswer
 

Ajout de fax ou de salle de réunion terminé.
La création du fichier résultats est correcte.
 
J'aimerais améliorer l'interface avant de passer à la suite.
Focus
Contrôler les inputs
 
Pour continuer, mais ce sera la semaine prochaine, le module de modification des noms et prénoms (numéros de bureau et de tel peuvent être changé directement sur la feuille "Liste".
 
Pour finir, un nettoyage :
- J'ai des zones qui ne servent pas.
- Mise en ordre de la feuille "Textes". Si j'ajoute une ligne, il n'y a plus aucun texte qui va correspondre, il y a moyen de régler le problème en mettant les données dans des zones nommées.
- J'ai trop de Public. Ça, c'est pour terminer.
 
Si quelqu'un veut tester : http://paf.im/u1S5P


Message édité par BrisChri le 20-05-2014 à 20:23:06

---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
n°2228570
BrisChri
Since 1956
Posté le 20-05-2014 à 20:22:26  profilanswer
 

Toute nouvelle version avec quelques changements.

  • Le fichier créé l'est d'office en 2 langues pour les titres, en 3 pour les renseignements.

Et oui, je travaille à Bruxelles et j'ai un collègue germanophone. Pas de raison de respecter la langue des uns et pas d'un autre.
Les modifs, pour celui qui voudrait utiliser le .xlsm, seront un peu plus longues.

  • Il n'y a plus qu'un seul UserForm pour le travail.

Pas un pour entrer les noms, un autre pour entrer les renseignements des locaux (fax, photocopie, salle de réunion, bibliothèque), non, 1 en tout et pour tout.
J'espère pouvoir m'y tenir pour la partie toujours pas entamée : les modifications.
 
Le formulaire est partagé en plusieurs cadres, ces cadres sont actifs ou non en fonction des besoins.

  • Pour une personne : Nom / Local / Rôle linguistique (RL)
  • Pour un local : Local / Type


 
Ajouter un local (menu principal)

Code :
  1. Private Sub BtAjBur_Click()
  2.     CacherMod
  3.     CacherNom
  4.     MontrerTel
  5.     CacherRL
  6.     MontrerTyp
  7.    
  8.     FrmTrav.LblCtrl.Caption = 1             '   nLigne = nMaxLigne + 1
  9.    
  10.     FrmMenu.Hide
  11.     FrmTrav.Show
  12. End Sub


 
avec, pour CacherMod()

Code :
  1. Sub CacherMod()
  2.     FrmTrav.FraMod.Enabled = False
  3.    
  4.     FrmTrav.ListBox1.Enabled = False
  5.     FrmTrav.ListBox1.Visible = False
  6. End Sub


Je suis certain qu'il doit être possible de faire ça plus simplement.
Si quelqu'un connaît l'instruction :  :jap:
 
Comment savoir ce qui doit être fait alors qu'il n'y a qu'un seul bouton OK ?
Simple comme bonjour : vérifier si le module est .enabled ou non.

Code :
  1. Private Sub BtTravOK_Click()
  2.     If FrmTrav.FraMod.Enabled = True Then
  3.         FrmTrav.LblCtrl = FrmTrav.LblCtrl / 0   '   ça ne devrait jamais arriver !!!
  4.     End If
  5.    
  6.     '   enregistrer les zones nom
  7.     If FrmTrav.FraNom.Enabled = True Then
  8.         RemplirNom
  9.     End If
  10.    
  11.     '   enregistrer les zones tel et bureau
  12.     If FrmTrav.FraTel.Enabled = True Then
  13.         RemplirTel
  14.     End If
  15.    
  16.     '   s'occuper du RL
  17.     If FrmTrav.FraRL.Enabled = True Then
  18.         RemplirRL
  19.     End If
  20.    
  21.     '   s'occuper du type
  22.     If FrmTrav.FraTyp.Enabled = True Then
  23.         RemplirTyp
  24.     End If
  25.     Select Case LblCtrl
  26.         Case Is = 1
  27.             CalculerLigne
  28.         Case Is = 2                         '   ne rien faire, nLigne est censé être connu
  29.         Case Is = 3                         '   ne rien faire, nLigne est censé être connu
  30.     End Select   
  31.     EcrireLigne
  32.     InitForm
  33. End Sub

Le select case disparaîtra s'il n'est vraiment pas nécessaire (remplacé par if = 1).
 
EcrireLigne() est la principale fonction.

  • Pour un local :

- Donner un nom connu en français (nLang = 1) au départ d'un tableau
- Normaliser le nom
- Id pour le prénom
- remplir les différentes colonnes nom et prénom
- attribuer un RL : 0 pour un Fax, 1 pour les autres locaux
- remplir tel et bur

  • Pour une personne :

- normaliser le nom et le prénom et remplir les colonnes
- tansformer le RL en valeur numérique, ce numéro servira :
  -  pour les couleurs qui sont dans une table
  -  pour remettre un RL à la création des listes
 
Me voila avec une liste simple, si simple que je ne peux l'imprimer telle quelle : les locaux, même s'ils n'ont pas vraiment un RL, doivent apparaître en FR et NL.
Pour imprimer, il faut d'abord créer la liste de travail.
Recopier les renseignements d'une personne.
Doubler la ligne pour les locaux en mettant les données dans la seconde langue.
 
On peut imprimer...
Trier dans l'ordre voulu et créer la page avec soit nom-prénom, soit prénom-nom dans la colonne de données.
Simple.
 
Que reste-t-il à faire :

  • Les modifications.
  • Le début de l'application : savoir qui est au clavier pour avoir les textes dans sa langue (pour l'instant, je court-circuite en mettant les renseignement sur une feuille)
  • Les sorties.

- Temporaire (sortir du menu) : pour permettre de changer des numéros de téléphones ou de bureau sans passer par le formulaire (quand on est 50 à déménager, le formulaire n'est pas une solution pratique).
  Réafficher le formulaire en revenant sur la page menu... Oui, mais quel formulaire ? Si je sais qui travaillait, inutile de demander, si c'est la première ouverture, je ne sais pas si Jarre est au clavier.
  Je pense que ça doit pouvoir se régler en lançant QuiTravaille à l'ouverture du classeur et Menu à l'accès à la feuille Manu. A voir.
- Définitive (sortir de l'application) : supprimer les renseignements relatifs à celui qui travaille, fermer le classeur.
- En cours de travail (après création des listes) : id sortie appl.
 
Tel_HFR.xslm : http://paf.im/0p0x0
TelService.xslx : http://paf.im/c4lsl
Si vous lancez la création des listes, le fichier est créé dans un sous-répertoire, pas dans celui d'où vous lancez la macro (FrmMenu)


---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
n°2228967
BrisChri
Since 1956
Posté le 25-05-2014 à 14:50:39  profilanswer
 

Code :
  1. Option Explicit
  2. Private Sub BtAjBur_Click()
  3.     CacherMod
  4.     CacherNom
  5.     MontrerTel
  6.     CacherRL
  7.     MontrerTyp
  8.    
  9.     FrmTrav.LblCtrl.Caption = 1             '   nLigne = nMaxLigne + 1
  10.    
  11.     FrmTrav.Caption = Range("TblMenu" ).Cells(4, Range("User" ).Cells(1, 1))
  12.     FrmMenu.Hide
  13.     FrmTrav.Show
  14. End Sub
  15. Private Sub BtAjNom_Click()
  16.    
  17.     CacherMod
  18.     MontrerNom
  19.     MontrerTel
  20.     MontrerRL
  21.     CacherTyp
  22.    
  23.     FrmTrav.LblCtrl.Caption = 1             '   nLigne = nMaxLigne + 1
  24.    
  25.     FrmTrav.Caption = Range("TblMenu" ).Cells(2, Range("User" ).Cells(1, 1))
  26.     FrmMenu.Hide
  27.     FrmTrav.Show
  28. End Sub
  29. Private Sub BtListes_Click()
  30.     CreerListes
  31. End Sub
  32. Private Sub BtModNom_Click()
  33.     FrmTrav.FraMod.Enabled = True
  34.     FrmTrav.FraNom.Enabled = False
  35.     FrmTrav.FraTel.Enabled = False
  36.     FrmTrav.FraRL.Enabled = False
  37.     FrmTrav.FraTyp.Enabled = False
  38.    
  39.     FrmTrav.LblCtrl.Caption = 2             '   nLigne devrait être connue !!!
  40.    
  41.     FrmMenu.Hide
  42.     FrmTrav.Show
  43. End Sub
  44. Private Sub BtSortirAppl_Click()
  45.     ThisWorkbook.Close (True)
  46. End Sub
  47. Private Sub BtSortirMenu_Click()
  48.     FrmMenu.Hide
  49.     Application.Goto ActiveWorkbook.Sheets("Liste" ).Cells(1, 1)
  50. End Sub


 

Code :
  1. Option Explicit
  2. Private Sub BtSortirTrav_Click()
  3.     FrmTrav.Hide
  4.     FrmMenu.Show
  5. End Sub
  6. Private Sub BtTravOK_Click()
  7.     If FrmTrav.FraMod.Enabled = True Then
  8.         FrmTrav.LblCtrl = FrmTrav.LblCtrl / 0   '   ça ne devrait jamais arriver !!!
  9.     End If
  10.    
  11.     '   enregistrer les zones nom
  12.     If FrmTrav.FraNom.Enabled = True Then
  13.         RemplirNom
  14.     End If
  15.    
  16.     '   enregistrer les zones tel et bureau
  17.     If FrmTrav.FraTel.Enabled = True Then
  18.         RemplirTel
  19.     End If
  20.    
  21.     '   s'occuper du RL
  22.     If FrmTrav.FraRL.Enabled = True Then
  23.         RemplirRL
  24.     End If
  25.    
  26.     '   s'occuper du type
  27.     If FrmTrav.FraTyp.Enabled = True Then
  28.         RemplirTyp
  29.     End If
  30.    
  31.     Select Case LblCtrl
  32.         Case Is = 1
  33.             CalculerLigne
  34.         Case Is = 2                         '   ne rien faire, nLigne est censé être connu
  35.         Case Is = 3                         '   ne rien faire, nLigne est censé être connu
  36.     End Select
  37.    
  38.     EcrireLigne
  39.     InitForm
  40. End Sub


 

Code :
  1. Option Explicit
  2. Dim wbFrom As Workbook                      '   ce classeur
  3. Dim wbTo As Workbook                        '   classeur listes
  4. Dim wsMenu As Worksheet
  5. Dim wsListe As Worksheet
  6. Dim wsTrav As Worksheet
  7. Dim wsLib As Worksheet
  8. Dim wsGest As Worksheet
  9. Dim wsConfig As Worksheet
  10. Dim wsTo As Worksheet
  11. Dim wsSauve As Worksheet
  12. Dim rCell1 As Range                         '   1 cellule à la fois (utilisé pour la MFC de Nom!)
  13. Dim nLangUser As Long                       '   langue de l'utilisateur de l'application
  14. Dim nLang As Long                           '   langue du client
  15. Dim sRep As String
  16. Dim sFich As String
  17. Dim sForm As String
  18. Dim nLigne As Long
  19. Dim nLigneTo As Long
  20. Dim nMaxLigne As Long
  21. Dim nCol As Long
  22. Dim tData(12) As String
  23. Dim tLang(3) As String
  24. Dim k1 As Long                              '   clef de tri
  25. Dim k2 As Long
  26. Dim tColOut(3) As Long                      '   nbr de ligne de données par colonne
  27. Dim tColorLang(3) As Long                   '   tables des couleurs par langue (voir constantes de couleur)
  28. Dim tColorTyp(6) As Long                    '                           typ
  29. Dim nLigneTitre As Long                     '   numéro de la dernière ligne de titre
  30. Dim nLigneDonnee As Long                    '      "    "  "    "        "   " donnée
  31. Dim nLigneRens As Long                      '      "    "  "    "        "   " renseignements
  32. Dim i As Long
  33. Dim j As Long
  34. Dim k As Long
  35. Dim l As Long
  36. '
  37. '   Constantes
  38. '
  39. Const Personne As Long = 1
  40. Const Fax As Long = 2
  41. Const Salle As Long = 3
  42. Const Photo As Long = 4
  43. Const Bib As Long = 5
  44. Const Extern As Long = 6
  45. Const ncNom As Long = 1
  46. Const ncPrenom As Long = 2
  47. Const ncBur As Long = 3
  48. Const ncTel As Long = 4
  49. Const ncRL As Long = 5
  50. Const ncNomPrenom As Long = 6
  51. Const ncPrenomNom As Long = 7
  52. Const ncCode As Long = 8
  53. Const ncNomNorm As Long = 9
  54. Const ncPrenomNorm As Long = 10
  55. Const ncNomTri As Long = 11
  56. Const ncPrenomTri As Long = 12
  57. Const nMaxCol As Long = 12
  58. '   couleurs
  59. Const colorLang1 As Byte = 35    '   voir feuille ColorIndex avant changement
  60. Const colorLang2 As Byte = 34
  61. Const colorLang3 As Byte = 19
  62. Const colorFax As Byte = 37
  63. Const colorSalle As Byte = 38
  64. Const colorPhoto As Byte = 39
  65. Const colorBib As Byte = 40
  66. Const colorExtern As Byte = 40
  67. Sub CreerListes()
  68.     CopierListeTrav
  69.     PreparerPrt
  70.     CreerPages
  71.     '   enregistrer le fichier
  72.     EcrireFichier
  73.     nMaxLigne = wsTrav.Range("A" & Rows.Count).End(xlUp).Row
  74.     wsTrav.Range(Cells(2, 1), Cells(nMaxLigne, nMaxCol)).ClearContents
  75. End Sub
  76. Sub PreparerPrt()
  77.     For i = 1 To 3
  78.         tColOut(i) = 0
  79.     Next i
  80.     wsConfig.Range("A4" ).Value = Date$
  81.     nMaxLigne = wsTrav.Range("A" & Rows.Count).End(xlUp).Row
  82.     j = 0
  83.     For i = 2 To nMaxLigne
  84.         j = j + 1
  85.         If j > 3 Then
  86.             j = 1
  87.         End If
  88.         tColOut(j) = tColOut(j) + 1
  89.     Next i
  90. End Sub
  91. Sub CreerPages()
  92.     '   Créer le fichier
  93.     Set wbTo = Workbooks.Add(1)
  94.    
  95.     ' et le remplir
  96.     TrierSurBureau
  97.     ActiveSheet.Name = "Bureau"
  98.     Set wsTo = wbTo.Sheets(1)
  99.     Call EcrirePage(ncNomPrenom)
  100.    
  101.         ' et le remplir
  102.     TrierSurRLPrenom
  103.     wbTo.Worksheets.Add(before:=Worksheets(1)).Name = "Langue et Prénoms"
  104.     Set wsTo = wbTo.Sheets(1)
  105.     Call EcrirePage(ncPrenomNom)
  106.    
  107.     TrierSurRLNom
  108.     wbTo.Worksheets.Add(before:=Worksheets(1)).Name = "Langue et Noms"
  109.     Set wsTo = wbTo.Sheets(1)
  110.     Call EcrirePage(ncNomPrenom)
  111.    
  112.     TrierSurPrenom
  113.     wbTo.Worksheets.Add(before:=Worksheets(1)).Name = "Prénoms"
  114.     Set wsTo = wbTo.Sheets(1)
  115.     Call EcrirePage(ncPrenomNom)
  116.  
  117.     TrierSurNom
  118.     wbTo.Worksheets.Add(before:=Worksheets(1)).Name = "Noms"
  119.     Set wsTo = wbTo.Sheets(1)
  120.     Call EcrirePage(ncNomPrenom)
  121.     MFCModif
  122. End Sub
  123. Sub EcrirePage(NomOuPrenom As Long)
  124.     '   écrire le titre
  125.     wsTo.Range("C3" ).Value = wsConfig.Range("A2" )
  126.     wsTo.Range("C4" ).Value = wsConfig.Range("A3" )
  127.     wsTo.Range("C5" ).Value = "-   " & Format(wsConfig.Range("A4" ), "dd-mm-yyyy" ) & "   -"
  128.     nLigneTitre = 5
  129.    
  130.     nLigneDonnee = nLigneTitre + 1
  131.     '   copier les données
  132.     k = 1
  133.     For i = 1 To 3
  134.     nCol = ((i - 1) * 5) + 3
  135.         For j = 1 To tColOut(i)
  136.             k = k + 1
  137.             wsTo.Cells(j + nLigneDonnee, nCol).Value = wsTrav.Cells(k, ncBur)
  138.             wsTo.Cells(j + nLigneDonnee, nCol).HorizontalAlignment = xlCenter
  139.             wsTo.Cells(j + nLigneDonnee, nCol + 1).Value = wsTrav.Cells(k, NomOuPrenom)
  140.             wsTo.Cells(j + nLigneDonnee, nCol + 2).Value = tLang(wsTrav.Cells(k, ncRL))
  141.             wsTo.Cells(j + nLigneDonnee, nCol + 2).HorizontalAlignment = xlCenter
  142.             wsTo.Cells(j + nLigneDonnee, nCol + 3).Value = wsTrav.Cells(k, ncTel)
  143.             wsTo.Cells(j + nLigneDonnee, nCol + 3).HorizontalAlignment = xlCenter
  144.             If wsTrav.Cells(k, ncCode) = Personne Then
  145.                 wsTo.Cells(j + nLigneDonnee, nCol + 2).Interior.ColorIndex = tColorLang(wsTrav.Cells(k, ncRL))
  146.             Else    'If wsTrav.Cells(k, ncCode) = Fax Then
  147.                 wsTo.Cells(j + nLigneDonnee, ((i - 1) * 5) + 4).Interior.ColorIndex = tColorTyp(wsTrav.Cells(k, ncCode))
  148.                 wsTo.Cells(j + nLigneDonnee, nCol + 2).Value = " "  '   rôle linguistique
  149.             End If
  150.         Next j
  151.     Next i
  152.     nLigneDonnee = nLigneDonnee + tColOut(1) + 1
  153.    
  154.     '   copier renseignements généraux
  155.     nLigneRens = 0
  156.     EcrireRens                                                      '   mettre en commentaire si pas utile !!!!
  157.     nLigneRens = nLigneDonnee + nLigneRens
  158.    
  159.     '   Aligner le titre
  160.     wsTo.Range("C3:P3" ).MergeCells = True
  161.     wsTo.Range("C4:P4" ).MergeCells = True
  162.     wsTo.Range("C5:P5" ).MergeCells = True
  163.     wsTo.Range("C3:P5" ).HorizontalAlignment = xlCenter
  164.    
  165.     '   Fonte Titre
  166.     'With wsTo.Range(Cells(L1, C1), Cells(L2, C2).Font
  167.     '    .Name = "Tahoma"
  168.     'End With
  169.    
  170.     '   Fonte données
  171.     'With wsTo.Range(Cells(L1, C1), Cells(L2, C2).Font
  172.     '    .Name = "Tahoma"
  173.     'End With
  174.    
  175.     '   Hauteur et Largeur des cellules
  176.     j = wsConfig.Range("A5" ).End(xlToRight).Column
  177.     For i = 1 To j
  178.         wsTo.Columns(i).ColumnWidth = wsConfig.Cells(5, i)
  179.     Next i
  180.     wsTo.Rows(1).RowHeight = wsConfig.Cells(6, 1)
  181.     wsTo.Rows(2).RowHeight = wsConfig.Cells(6, 1)
  182.     wsTo.Rows(nLigneTitre + 1).RowHeight = wsConfig.Cells(6, 1)
  183.     wsTo.Rows(nLigneDonnee).RowHeight = wsConfig.Cells(6, 1)
  184.     wsTo.Rows(nLigneRens).RowHeight = wsConfig.Cells(6, 1)
  185.    
  186.     '   encadrement
  187.     Call CadreListe(3, 3, nLigneTitre, 16)                          '   cadre titre
  188.     Call CadreListe(2 + nLigneTitre, 3, 6 + tColOut(1), 6)          '   colonne 1 des données
  189.     Call CadreListe(2 + nLigneTitre, 8, 6 + tColOut(2), 11)
  190.     Call CadreListe(2 + nLigneTitre, 13, 6 + tColOut(3), 16)
  191.     Call CadreListe(2, 2, nLigneRens, 17)                           '   autour de tout
  192.    
  193.     '   une ligne sur le haut et sur la bas
  194.     Call DemiCadreListe(2 + nLigneTitre, 3, 6 + tColOut(1), 6)      '   colonne 1 des données
  195.     Call DemiCadreListe(2 + nLigneTitre, 8, 6 + tColOut(2), 11)
  196.     Call DemiCadreListe(2 + nLigneTitre, 13, 6 + tColOut(3), 16)
  197.    
  198.     '   Supprimer le quadrillage
  199.     ActiveWindow.DisplayGridlines = False
  200. End Sub
  201. Sub MFCModif()
  202.     nLigne = nLigneTitre + 1
  203.     For i = 1 To 3
  204.     nCol = ((i - 1) * 5) + 3
  205.         For j = 1 To tColOut(i)
  206.             For k = nCol To nCol + 3
  207.                 Set rCell1 = wsTo.Cells(j + nLigne, k)
  208.                 With rCell1
  209.                     .FormatConditions.Add Type:=xlCellValue, Operator:=xlNotEqual, Formula1:=rCell1
  210.                     .FormatConditions(rCell1.FormatConditions.Count).SetFirstPriority
  211.                    
  212.                     With rCell1.FormatConditions(1)
  213.                    
  214.                         With .Font
  215.                             .Color = -16776961
  216.                             .TintAndShade = 0
  217.                         End With
  218.                        
  219.                         With .Interior
  220.                             .PatternColorIndex = xlAutomatic
  221.                             .ThemeColor = xlThemeColorDark1
  222.                             .TintAndShade = -4.99893185216834E-02
  223.                         End With
  224.                        
  225.                     End With
  226.                     .FormatConditions(1).StopIfTrue = False
  227.                 End With
  228.             Next k
  229.         Next j
  230.     Next i
  231. End Sub
  232. Sub EcrireRens()                '   à améliorer (nbr fixe de lignes!)
  233.     nLigneRens = 7 + nLigneDonnee
  234.     For j = 1 To 3
  235.         k = ((j - 1) * 5) + 3
  236.         For i = 1 To 7
  237.             wsTo.Cells(nLigneDonnee + i, k) = wsConfig.Range("TblRens" ).Cells(i, j)
  238.             wsTo.Range(Cells(nLigneDonnee + i, k), Cells(nLigneDonnee + i, k + 3)).MergeCells = True
  239.         Next i
  240.     Next j
  241.     Call CadreListe(nLigneDonnee + 1, 3, nLigneRens, 16)    '   1 cadre pour les 3 langues
  242.    
  243.     nLigneRens = 8
  244. End Sub
  245. Sub CadreListe(L1 As Long, C1 As Long, L2 As Long, C2 As Long)
  246.     With wsTo.Range(Cells(L1, C1), Cells(L2, C2))
  247.         .Borders(xlEdgeLeft).Weight = xlThin
  248.         .Borders(xlEdgeTop).Weight = xlThin
  249.         .Borders(xlEdgeBottom).Weight = xlThin
  250.         .Borders(xlEdgeRight).Weight = xlThin
  251.     End With
  252. End Sub
  253. Sub DemiCadreListe(L1 As Long, C1 As Long, L2 As Long, C2 As Long)
  254.     Dim nLigne As Long
  255.     Dim nCol As Long
  256.    
  257.     For nLigne = L1 To L2
  258.         For nCol = C1 To C2
  259.             wsTo.Cells(nLigne, nCol).Borders(xlEdgeTop).Weight = xlThin
  260.             wsTo.Cells(nLigne, nCol).Borders(xlEdgeBottom).Weight = xlThin
  261.         Next nCol
  262.     Next nLigne
  263. End Sub
  264. Sub CopierListeTrav()
  265.     nMaxLigne = wsListe.Range("A" & Rows.Count).End(xlUp).Row
  266.     nLigneTo = 2
  267.     For nLigne = 2 To nMaxLigne
  268.         For i = 1 To nMaxCol
  269.             wsTrav.Cells(nLigneTo, i) = wsListe.Cells(nLigne, i)
  270.         Next i
  271.         '   si c'est fax ou extern: ligne unique, RL=0
  272.         If wsListe.Cells(nLigne, ncCode) = Fax Or wsListe.Cells(nLigne, ncCode) = Extern Then
  273.                 wsTrav.Cells(nLigneTo, ncRL) = 0
  274.         ElseIf wsListe.Cells(nLigne, ncCode) <> Personne Then
  275.             '   sinon: créer un ligne RL=2 (avec data en NL)
  276.             nLigneTo = nLigneTo + 1
  277.             j = wsTrav.Cells(nLigneTo - 1, ncCode)
  278.             wsTrav.Cells(nLigneTo, ncNom) = Range("tblcode" ).Cells(j, 2)
  279.             wsTrav.Cells(nLigneTo, ncPrenom) = wsTrav.Cells(nLigneTo, ncNom)
  280.             wsTrav.Cells(nLigneTo, ncBur) = wsListe.Cells(nLigne, ncBur)    '   données sur la ligne précédente
  281.             wsTrav.Cells(nLigneTo, ncTel) = wsListe.Cells(nLigne, ncTel)    '   données sur la ligne précédente
  282.             wsTrav.Cells(nLigneTo, ncRL) = 2
  283.             wsTrav.Cells(nLigneTo, ncNomPrenom) = wsTrav.Cells(nLigneTo, ncNom)
  284.             wsTrav.Cells(nLigneTo, ncPrenomNom) = wsTrav.Cells(nLigneTo, ncNom)
  285.             wsTrav.Cells(nLigneTo, ncCode) = wsListe.Cells(nLigne, ncCode)
  286.             wsTrav.Cells(nLigneTo, ncNomTri) = Normaliser(wsTrav.Cells(nLigneTo, ncNom))
  287.             wsTrav.Cells(nLigneTo, ncPrenomTri) = wsTrav.Cells(nLigneTo, ncNomTri)
  288.         End If
  289.         nLigneTo = nLigneTo + 1
  290.     Next nLigne
  291. End Sub
  292. Sub RemplirNom()
  293.     tData(ncNom) = LTrim(RTrim(FrmTrav.TextNom))
  294.     tData(ncPrenom) = LTrim(RTrim(FrmTrav.TextPrenom))
  295.     tData(ncNomPrenom) = tData(ncNom) & " " & tData(ncPrenom)
  296.     tData(ncPrenomNom) = tData(ncPrenom) & " " & tData(ncNom)
  297.     tData(ncNomNorm) = Normaliser(tData(ncNom))
  298.     tData(ncPrenomNorm) = Normaliser(tData(ncPrenom))
  299.     tData(ncNomTri) = tData(ncNomNorm) & " " & tData(ncPrenomNorm)
  300.     tData(ncPrenomTri) = tData(ncPrenomNorm) & " " & tData(ncNomNorm)
  301.    
  302.     tData(ncCode) = 1
  303. End Sub
  304. Sub RemplirTel()
  305.     tData(ncBur) = LTrim(RTrim(FrmTrav.TextBur))
  306.     If tData(ncBur) = "" Then
  307.         tData(ncBur) = "~"
  308.     End If
  309.    
  310.     tData(ncTel) = LTrim(RTrim(FrmTrav.TextTel))
  311.     If tData(ncTel) = "" Then
  312.         tData(ncTel) = "~"
  313.     End If
  314. End Sub
  315. Sub RemplirRL()
  316.     If FrmTrav.OpBuLang1 = True Then
  317.         tData(ncRL) = 1
  318.     ElseIf FrmTrav.OpBuLang2 = True Then
  319.         tData(ncRL) = 2
  320.     ElseIf FrmTrav.OpBuLang3 = True Then
  321.         tData(ncRL) = 3
  322.     ElseIf FrmTrav.OpBuTyp5 = True Then
  323.         i = 6
  324.         RemplirDonneesTyp
  325.     End If
  326. End Sub
  327. Sub RemplirTyp()
  328.     If FrmTrav.OpBuTyp1 = True Then
  329.         i = 2
  330.     ElseIf FrmTrav.OpBuTyp2 = True Then
  331.         i = 3
  332.     ElseIf FrmTrav.OpBuTyp3 = True Then
  333.         i = 4
  334.     Else
  335.         i = 5
  336.     End If
  337.     tData(ncNom) = Range("TblCode" ).Cells(i, 1)
  338.     RemplirDonneesTyp
  339. End Sub
  340. Sub RemplirDonneesTyp()
  341.     'tData(ncNom) = Range("TblCode" ).Cells(i, 1)        '   typ = 6, ncNom est déjà rempli
  342.     'tData(ncPrenom) = tData(ncNom)
  343.     tData(ncRL) = 1
  344.     tData(ncNomPrenom) = tData(ncNom)
  345.     tData(ncPrenomNom) = tData(ncNom)
  346.     tData(ncCode) = i
  347.     tData(ncNomTri) = Normaliser(tData(ncNom))
  348.     tData(ncPrenomTri) = tData(ncNomTri)
  349. End Sub
  350. Sub InitForm()
  351.     FrmTrav.TextNom = tData(ncNom)
  352.     FrmTrav.TextPrenom = tData(ncPrenom)
  353.     FrmTrav.TextBur = tData(ncBur)
  354.     FrmTrav.TextTel = tData(ncTel)
  355.     '   rl
  356.     FrmTrav.OpBuLang1 = False
  357.     FrmTrav.OpBuLang2 = False
  358.     FrmTrav.OpBuLang3 = False
  359.     FrmTrav.OpBuTyp5 = False
  360.     '   typ
  361.     FrmTrav.OpBuTyp1 = False
  362.     FrmTrav.OpBuTyp2 = False
  363.     FrmTrav.OpBuTyp3 = False
  364.     FrmTrav.OpBuTyp4 = False
  365. End Sub
  366. Sub RemplirTable()
  367.     For nCol = 1 To nMaxCol
  368.         tData(nCol) = Cells(nLigne, nCol)
  369.     Next nCol
  370. End Sub
  371. Sub EcrireLigne()
  372.     wsListe.Unprotect
  373.     For nCol = 1 To nMaxCol
  374.         wsListe.Cells(nLigne, nCol) = tData(nCol)
  375.         tData(nCol) = ""                    '   mettre la table à blanc après écriture
  376.     Next nCol
  377.     TrierListeSurNom
  378.     wsListe.Protect
  379. End Sub
  380. Sub TrierListeSurNom()
  381.     k1 = ncNomTri
  382.     With wsListe.Sort
  383.         .SortFields.Clear
  384.         .SortFields.Add Key:=Range(Cells(1, k1), Cells(nMaxLigne, k1))
  385.         .SetRange Range(Cells(1, 1), Cells(nMaxLigne, nMaxCol))
  386.         .Header = xlYes
  387.         .MatchCase = False
  388.         .Orientation = xlSortColumns
  389.         .Apply
  390.     End With
  391. End Sub
  392. Sub TrierSurNom()
  393.     k1 = ncNomTri
  394.     TrierListe1
  395. End Sub
  396. Sub TrierSurPrenom()
  397.     k1 = ncPrenomTri
  398.     TrierListe1
  399. End Sub
  400. Sub TrierSurRLNom()
  401.     k1 = ncRL
  402.     k2 = ncNomTri
  403.     TrierListe2
  404. End Sub
  405. Sub TrierSurRLPrenom()
  406.     k1 = ncRL
  407.     k2 = ncPrenomTri
  408.     TrierListe2
  409. End Sub
  410. Sub TrierSurBureau()
  411.     k1 = ncBur
  412.     k2 = ncNomTri
  413.     TrierListe2
  414. End Sub
  415. Sub TrierListe1()
  416.     With wsTrav.Sort
  417.         .SortFields.Clear
  418.         .SortFields.Add Key:=Range(Cells(1, k1), Cells(nMaxLigne, k1))
  419.         .SetRange Range(Cells(1, 1), Cells(nMaxLigne, nMaxCol))
  420.         .Header = xlYes
  421.         .MatchCase = False
  422.         .Orientation = xlSortColumns
  423.         .Apply
  424.     End With
  425. End Sub
  426. Sub TrierListe2()
  427.     With wsTrav.Sort
  428.         .SortFields.Clear
  429.         .SortFields.Add Key:=Range(Cells(1, k1), Cells(nMaxLigne, k1))
  430.         .SortFields.Add Key:=Range(Cells(1, k2), Cells(nMaxLigne, k2))
  431.         .SetRange Range(Cells(1, 1), Cells(nMaxLigne, nMaxCol))
  432.         .Header = xlYes
  433.         .MatchCase = False
  434.         .Orientation = xlSortColumns
  435.         .Apply
  436.     End With
  437. End Sub
  438. Sub CalculerLigne()
  439.     nMaxLigne = wsListe.Range("A" & Rows.Count).End(xlUp).Row + 1
  440.     nLigne = nMaxLigne
  441. End Sub
  442. Sub CacherMod()
  443.     FrmTrav.FraMod.Enabled = False
  444.    
  445.     FrmTrav.ListBox1.Enabled = False
  446.     FrmTrav.ListBox1.Visible = False
  447. End Sub
  448. Sub CacherNom()
  449.     FrmTrav.FraNom.Enabled = False
  450.    
  451.     FrmTrav.TextNom.Enabled = False
  452.     FrmTrav.TextPrenom.Enabled = False
  453.     FrmTrav.TextNom.Visible = False
  454.     FrmTrav.TextPrenom.Visible = False
  455.     FrmTrav.LblNom.Visible = False
  456.     FrmTrav.LblPrenom.Visible = False
  457. End Sub
  458. Sub CacherTel()
  459.     FrmTrav.FraTel.Enabled = False
  460.    
  461.     FrmTrav.TextTel.Enabled = False
  462.     FrmTrav.TextBur.Enabled = False
  463.     FrmTrav.TextTel.Visible = False
  464.     FrmTrav.TextBur.Visible = False
  465. End Sub
  466. Sub CacherRL()
  467.     FrmTrav.FraRL.Enabled = False
  468.    
  469.     FrmTrav.OpBuLang1.Enabled = False
  470.     FrmTrav.OpBuLang2.Enabled = False
  471.     FrmTrav.OpBuLang3.Enabled = False
  472.     FrmTrav.OpBuTyp5.Enabled = False
  473.     FrmTrav.OpBuLang1.Visible = False
  474.     FrmTrav.OpBuLang2.Visible = False
  475.     FrmTrav.OpBuLang3.Visible = False
  476.     FrmTrav.OpBuTyp5.Visible = False
  477. End Sub
  478. Sub CacherTyp()
  479.     FrmTrav.FraTyp.Enabled = False
  480.    
  481.     FrmTrav.OpBuTyp1.Enabled = False
  482.     FrmTrav.OpBuTyp2.Enabled = False
  483.     FrmTrav.OpBuTyp3.Enabled = False
  484.     FrmTrav.OpBuTyp4.Enabled = False
  485.     FrmTrav.OpBuTyp1.Visible = False
  486.     FrmTrav.OpBuTyp2.Visible = False
  487.     FrmTrav.OpBuTyp3.Visible = False
  488.     FrmTrav.OpBuTyp4.Visible = False
  489. End Sub
  490. Sub MontrerMod()
  491.     FrmTrav.FraMod.Enabled = True
  492.    
  493.     FrmTrav.ListBox1.Enabled = True
  494.     FrmTrav.ListBox1.Visible = True
  495. End Sub
  496. Sub MontrerNom()
  497.     FrmTrav.FraNom.Enabled = True
  498.    
  499.     FrmTrav.TextNom.Enabled = True
  500.     FrmTrav.TextPrenom.Enabled = True
  501.     FrmTrav.TextNom.Visible = True
  502.     FrmTrav.TextPrenom.Visible = True
  503.     FrmTrav.LblNom.Visible = True
  504.     FrmTrav.LblPrenom.Visible = True
  505. End Sub
  506. Sub MontrerTel()
  507.     FrmTrav.FraTel.Enabled = True
  508.    
  509.     FrmTrav.TextTel.Enabled = True
  510.     FrmTrav.TextBur.Enabled = True
  511.     FrmTrav.TextTel.Visible = True
  512.     FrmTrav.TextBur.Visible = True
  513. End Sub
  514. Sub MontrerRL()
  515.     FrmTrav.FraRL.Enabled = True
  516.    
  517.     FrmTrav.OpBuLang1.Enabled = True
  518.     FrmTrav.OpBuLang2.Enabled = True
  519.     FrmTrav.OpBuLang3.Enabled = True
  520.     FrmTrav.OpBuTyp5.Enabled = True
  521.     FrmTrav.OpBuLang1.Visible = True
  522.     FrmTrav.OpBuLang2.Visible = True
  523.     FrmTrav.OpBuLang3.Visible = True
  524.     FrmTrav.OpBuTyp5.Visible = True
  525. End Sub
  526. Sub MontrerTyp()
  527.     FrmTrav.FraTyp.Enabled = True
  528.    
  529.     FrmTrav.OpBuTyp1.Enabled = True
  530.     FrmTrav.OpBuTyp2.Enabled = True
  531.     FrmTrav.OpBuTyp3.Enabled = True
  532.     FrmTrav.OpBuTyp4.Enabled = True
  533.     FrmTrav.OpBuTyp1.Visible = True
  534.     FrmTrav.OpBuTyp2.Visible = True
  535.     FrmTrav.OpBuTyp3.Visible = True
  536.     FrmTrav.OpBuTyp4.Visible = True
  537. End Sub
  538. Sub AfficherNomUser()
  539.    
  540.     With FrmMenu
  541.         .FraUser.Caption = Range("Accueil" ).Cells(1, nLangUser)
  542.         .LabUserName.Caption = Range("User" ).Cells(1, 2)
  543.        
  544.         .BtAjNom.Caption = Range("TblMenu" ).Cells(2, nLangUser)
  545.         .BtModNom.Caption = Range("TblMenu" ).Cells(3, nLangUser)
  546.         .BtAjBur.Caption = Range("TblMenu" ).Cells(4, nLangUser)
  547.         .BtModBur.Caption = Range("TblMenu" ).Cells(5, nLangUser)
  548.         .BtListes.Caption = Range("TblMenu" ).Cells(6, nLangUser)
  549.         .BtSortirMenu.Caption = Range("TblMenu" ).Cells(7, nLangUser)
  550.         .BtSortirAppl.Caption = Range("TblMenu" ).Cells(8, nLangUser)
  551.        
  552.     End With
  553.    
  554.     With FrmTrav
  555.         .FraUser.Caption = Range("Accueil" ).Cells(1, nLangUser)
  556.         .LabUserName.Caption = Range("User" ).Cells(1, 2)
  557.        
  558.         .FraMod.Caption = ""
  559.        
  560.         .FraNom.Caption = ""
  561.         .LblNom.Caption = Range("TblTrav" ).Cells(1, nLangUser)
  562.         .LblPrenom.Caption = Range("TblTrav" ).Cells(2, nLangUser)
  563.        
  564.         .FraTel.Caption = ""
  565.         .LblTel.Caption = Range("TblTrav" ).Cells(3, nLangUser)
  566.         .LblBur.Caption = Range("TblTrav" ).Cells(4, nLangUser)
  567.        
  568.         .FraRL.Caption = ""
  569.         .OpBuLang1.Caption = Range("TblMenu" ).Cells(1, 1)
  570.         .OpBuLang2.Caption = Range("TblMenu" ).Cells(1, 2)
  571.         .OpBuLang3.Caption = Range("TblMenu" ).Cells(1, 3)
  572.         .OpBuTyp5.Caption = Range("TblTrav" ).Cells(9, nLangUser)
  573.        
  574.         .FraTyp.Caption = ""
  575.         .OpBuTyp1.Caption = Range("TblTrav" ).Cells(5, nLangUser)
  576.         .OpBuTyp2.Caption = Range("TblTrav" ).Cells(6, nLangUser)
  577.         .OpBuTyp3.Caption = Range("TblTrav" ).Cells(7, nLangUser)
  578.         .OpBuTyp4.Caption = Range("TblTrav" ).Cells(8, nLangUser)
  579.        
  580.         .BtTravOK.Caption = Range("TblTrav" ).Cells(10, nLangUser)
  581.         .BtSortirTrav.Caption = Range("TblTrav" ).Cells(11, nLangUser)
  582.     End With
  583. End Sub
  584. Sub QuiTravaille()                          '   A compléter : nouveau fichier !
  585.     'Range("User" ).Cells(1, 1).Value = 1
  586.     'Range("User" ).Cells(1, 2).Value = "Christian"
  587.     'Range("EnCours" ).Cells(1, 1).Value = 1
  588.    
  589.     nLangUser = Range("User" ).Cells(1, 1)
  590. End Sub
  591. Sub EcrireFichier()
  592.     sFich = sRep & "TelService.xlsx"
  593.     Application.DisplayAlerts = False
  594.     wbTo.SaveAs Filename:=sFich, AccessMode:=xlExclusive, ConflictResolution:=Excel.XlSaveConflictResolution.xlLocalSessionChanges
  595.     wbTo.Close (True)
  596.     Application.DisplayAlerts = True
  597. End Sub
  598. Sub OuTravailler()
  599.     sRep = wbFrom.Path
  600.     sRep = sRep & "\PhoneFiles\"
  601.     If Dir(sRep, vbDirectory) = "" Then MkDir sRep
  602. End Sub
  603. Sub InitAppl()
  604.     Set wbFrom = ThisWorkbook
  605.    
  606.     Set wsMenu = wbFrom.Sheets("Menu" )
  607.     Set wsListe = wbFrom.Sheets("Liste" )
  608.     Set wsTrav = wbFrom.Sheets("Travail" )
  609.     Set wsLib = wbFrom.Sheets("Libelles" )
  610.     Set wsGest = wbFrom.Sheets("Gestionnaires" )
  611.     Set wsConfig = wbFrom.Sheets("Config" )
  612.    
  613.     For i = 1 To 3
  614.         tLang(i) = Range("TblMenu" ).Cells(1, i)
  615.     Next i
  616.    
  617.     tColorLang(1) = colorLang1
  618.     tColorLang(2) = colorLang2
  619.     tColorLang(3) = colorLang3
  620.    
  621.     tColorTyp(2) = colorFax
  622.     tColorTyp(3) = colorSalle
  623.     tColorTyp(4) = colorPhoto
  624.     tColorTyp(5) = colorBib
  625.     tColorTyp(6) = colorExtern
  626.    
  627.     OuTravailler
  628.    
  629.     Load FrmMenu
  630.     Load FrmTrav
  631.    
  632.     QuiTravaille
  633.    
  634. End Sub
  635. Function Normaliser(ByVal Chaine$)
  636. Const Avec = "àáâãäåéêëèìíîïðòóôõöùúûüç"
  637. Const Sans = "aaaaaaeeeeiiiioooooouuuuc"
  638. Const Speciaux = "'- "
  639. Dim i As Byte
  640. Chaine = Format(Chaine, "<" )                '   format(string,"<" ) est plus rapide que string = LCase(string)
  641.     For i = 1 To Len(Speciaux)
  642.         Chaine = Replace(Chaine, Mid(Speciaux, i, 1), "" )
  643.     Next i
  644.     For i = 1 To Len(Avec)
  645.         Chaine = Replace(Chaine, Mid(Avec, i, 1), Mid(Sans, i, 1))
  646.     Next i
  647. Normaliser = Chaine
  648. End Function


 
telhfr.xlsm : http://paf.im/c1xVD
telservice.xlsx : http://paf.im/yev9m
 
FrmMenu
https://farm4.staticflickr.com/3741/14079021910_56a529758b_z.jpg
Clipboard01 par BrisChri, sur Flickr
 
FrmTrav lorsqu'on ajoute un nom
https://farm4.staticflickr.com/3747/14263514262_343870ef20_z.jpg
Clipboard02 par BrisChri, sur Flickr
 
FrmTrav lorsqu'on ajoute une salle
https://farm4.staticflickr.com/3818/14078995218_f2983db7b8_z.jpg
Clipboard03 par BrisChri, sur Flickr
 
Une erreur qui est régulière mais pas systématique. Elle n'apparît que lors de la création des listes (quand le travail est terminé)
https://farm4.staticflickr.com/3829/14078995448_0447e4d8f5_z.jpg
Clipboard04 par BrisChri, sur Flickr
 
La sélection se fait (contrairement au message d'erreur) l'effacement ne se fait pas.
https://farm4.staticflickr.com/3725/14262311761_aaa12a6529_z.jpg
Clipboard05 par BrisChri, sur Flickr


Message édité par BrisChri le 25-05-2014 à 15:16:45

---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine
n°2228978
Marc L
Posté le 25-05-2014 à 18:30:13  profilanswer
 

 
           Vérifier le contenu des variables est un début …
  

n°2228981
BrisChri
Since 1956
Posté le 25-05-2014 à 18:41:47  profilanswer
 

Quand j'ai ce message, ma plage est sélectionnée mais pas vidée.
Et quand je ne l'ai pas, elle est vide.

 

Problème réglé, ajout de
Application.Goto wsTrav.Cells(1, 1)
en première ligne de CreerListes


Message édité par BrisChri le 25-05-2014 à 19:15:56

---------------
Si une frite n'a pas de mayo, alors elle ne pourra pas aller à la piscine

Aller à :
Ajouter une réponse
  FORUM HardWare.fr
  Programmation
  VB/VBA/VBS

  VBA Excel Liste des numéros de téléphone d'un service

 

Sujets relatifs
Excel : Alimenter une colonne en fonction de deux critèresComment répartir aléatoirement 500h par an avec EXCEL 2007?
VBA simple : comment faire une série d'identifiant à partir d'un chiff[RESOLU] [VBA] Remplacement valeur via listbox
Macro VBA utilisant 2 WorkbooksVBA Excel : série de label_x_click()
VBA - Comment cacher le contenu d'une cellule grace au format de celluExécuter une macro au changement du contenu d'une cellule sous excel
VBA EXCEL Choisir la boite mail d'envoi lors d'un envoi via Outlook 
Plus de sujets relatifs à : VBA Excel Liste des numéros de téléphone d'un service


Copyright © 1997-2018 Hardware.fr SARL (Signaler un contenu illicite / Données personnelles) / Groupe LDLC / Shop HFR