Besoin d'aide pour manipulation chaine de caractère.

[jeremie.pa]

Bonjour

J'ai besoin de votre aide pour la création automatique de mes profils utilisateurs, (j'en ai 2000 à gérer)

j'importe ma liste d'utilisateur dans excel, sous cette forme :

matricule |Prénom | Nom | catégorie professionnel|

Je dois générer :

- login : 3 premières lettre du nom, 2 du prénom, pas d'accent, pas d'expace pas de maj, pas de doublon, en cas de doublon je dois incrémenter de 1.
- mail : prenom.nom@domaine.fr, pas d'accents pas de majuscules, et pas d'espace.

Je ne connais vraiment pas Excel mais je suis persuadé que c'est le bon outil pour générer ces données.

Donc pour le moment j'ai réussi à faire ceci :
- login : concaténation du prénom et du nom pour obtenir le login suppression des accents, et des espaces

Je n'arrive pas a faire le test des doublons, ou plutôt je ne sais pas par ou commencer ni comment.

Mail : idem, et pareil problème avec les doublons.

Pensez vous que je me lance dans quelque chose d'infaisable ? est ce que excel est le bon outils ?
je m'y prend sous doute mal, comment voyez vous le test des doublons ?

Avez vous des astuces à me donner ?

Et la petite cerise sur le gâteau est que ma liste d'utilisateur fluctue , donc je dois lancer régulierement cette génération de profil et isoler les anciens des nouveaux .... la j'aurais je ne sais pas comment m'y prendre non plus ? une liste intermédiaire ??? je ne sais pas !


D'avance je vous remercie

 

[PMO2]

Re : Besoin d'aide pour manipulation chaine de caractère.

Bonjour,

Etes-vous toujours intéressé car j'ai trouvé une solution ?
Dans l'affirmative, veuillez me faire signe.

PMO
Patrick Morange

 

[jeremie.pa]

Re : Besoin d'aide pour manipulation chaine de caractère.

Oui toujours intéressé !! plus que jamais !!!

 

[PMO2]

Re : Besoin d'aide pour manipulation chaine de caractère.

Bonjour,

Une solution en VBA avec le code suivant à copier dans un module standard.

ATTENTION faites l'essai sur une copie de votre classeur.

Je me suis basé sur ce que vous énonciez et ai donc fait
1) Création d'une feuille "test" avec, de A1 à F1, respectivement les titres suivants
matricule
Prénom
Nom
catégorie professionnel
login
mail
2) Je l'ai rempli de données avec des doublons, des espaces, des accents, divers caractères (apostrophe, tiret).
J'ai prévu un nom et un prénom dont le nombre de caractères est inférieur à 3 (cela peut arriver ???).
Tout cela est dans le classeur exemple joint.

Code à copier dans un module standard

'### Adapter les constantes selon son usage ###
Const FEUILLE As String = "test"
Const DOMAINE As String = "@domaine.fr"
'##############################################

Sub LoginsEtMails()
Dim S As Worksheet
Dim R As Range
Dim var
Dim var2
Dim A$
Dim B$
Dim prenom$
Dim nom$
Dim i&
Dim j&
Dim cpt&
Dim lastLig&
Dim bool As Boolean
Set S = Sheets(FEUILLE)
lastLig& = S.[b65536].End(xlUp).Row
var = S.Range(S.Cells(1, 1), S.Cells(lastLig&, 6))
Set R = S.Range(S.Cells(1, 5), S.Cells(lastLig&, 6))
var2 = R
For i& = 1 To lastLig&
  nom$ = Cleaning(var(i&, 3))
  prenom$ = Cleaning(var(i&, 2))
    '--- Login ---
  A$ = Trim(var(i&, 5))
  If A$ = "" Then
    A$ = Left(nom$, 3) & Left(prenom$, 2)
    cpt& = 0
    Do
      B$ = A$
      If cpt& > 0 Then B$ = B$ & cpt&
      bool = False
      For j& = LBound(var2, 1) To UBound(var2, 1)
        If B$ = var2(j&, 1) Then
          bool = True
          cpt& = cpt& + 1
          Exit For
        End If
      Next j&
    Loop Until bool = False
    var2(i&, 1) = B$
  End If
    '--- Mail ---
  A$ = Trim(var(i&, 6))
  If A$ = "" Then
    A$ = prenom$ & "." & nom$
    cpt& = 0
    Do
      B$ = A$
      If cpt& > 0 Then B$ = B$ & cpt&
      bool = False
      For j& = LBound(var2, 1) To UBound(var2, 1)
        If B$ & DOMAINE = var2(j&, 2) Then
          bool = True
          cpt& = cpt& + 1
          Exit For
        End If
      Next j&
    Loop Until bool = False
    var2(i&, 2) = B$ & DOMAINE
  End If
Next i&
R = var2
End Sub

Private Function Cleaning(ByVal Chaine As String) As String
Dim i&
Dim NoChar
Dim Accent
NoChar = Array(" ", "", "'", "", "-", "")
Accent = Array("à", "a", "â", "a", "è", "e", "é", "e", "ê", "e", "ë", "e", _
        "î", "i", "ï", "i", "ô", "o", "ö", "o", "ù", "u", "û", "u", "ü", "u")
For i& = LBound(NoChar) To UBound(NoChar) Step 2
  Chaine = Replace(Chaine, NoChar(i&), NoChar(i& + 1))
Next i&
For i& = LBound(Accent) To UBound(Accent) Step 2
  Chaine = Replace(Chaine, Accent(i&), Accent(i& + 1))
Next i&
Cleaning = LCase(Chaine)
End Function

Il faudra adapter,à votre usage, les constantes cernées par des ###

Cordialement.

PMO
Patrick Morange

 

[jeremie.pa]

Re : Besoin d'aide pour manipulation chaine de caractère.

Wouha !

merci je test ca demain dans la journée, je vous tiens au courant.

J'avais commencer à faire quelque chose en mixant formule excel et VBA ! mais ca commencais a être long et peu efficace !

Jérémie

 

[jeremie.pa]

Re : Besoin d'aide pour manipulation chaine de caractère.

Bonjour,

Alors je viens d'effectuer quelques test sur cette outil qui dans un premier temps répond parfaitement au résultat attendu !

Tout semble bien fonctionner !

J'aurais encore une petite question, j'effectue un import massif des employés depuis une base de donnée, donc tous les employés sont généré dans une feuille, il faudrait compléter la liste existante (sans la régénérer) est ce possible ?

J'étais au triple de votre code et je n'en faisais pas encore la moitié.....

 

[PMO2]

Re : Besoin d'aide pour manipulation chaine de caractère.

Bonjour,

J'ai ajouté la Sub ImportVersusTest pour résoudre le problème de compléter la liste sans toucher à l'existant.
Voici le code où cette procédure a été intégrée (ainsi qu'une nouvelle constante à adapter Const IMPORT As String = "import")

'### Adapter les constantes selon son usage ###
Const FEUILLE As String = "test"
Const DOMAINE As String = "@domaine.fr"
Const IMPORT As String = "import" 'dernière importation de la BDD
'##############################################

Sub ImportVersusTest()
Dim S As Worksheet
Dim S2 As Worksheet
Dim R As Range
Dim var
Dim var2
Dim lastLig&
Dim i&
Dim j&
Dim k&
On Error GoTo Erreur
Application.ScreenUpdating = False
Sheets(FEUILLE).Copy after:=Sheets(Sheets.Count)
Set S = ActiveSheet
lastLig& = S.[a65536].End(xlUp).Row
Set R = S.Range(S.Cells(1, 1), S.Cells(lastLig&, 6))
R.Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
var = R
R.ClearContents
Sheets(IMPORT).Cells.Copy
S.[a1].Select
ActiveSheet.Paste
lastLig& = S.[a65536].End(xlUp).Row
Set R = S.Range(S.Cells(1, 1), S.Cells(lastLig&, 6))
R.Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
var2 = R
R.ClearContents
For i& = 2 To UBound(var2, 1)
  For k& = 2 To UBound(var, 1)
    If Trim(var2(i&, 1)) = Trim(var(k&, 1)) Then
      If Trim(var(k&, 5)) <> "" And Trim(var(k&, 6)) <> "" Then
        For j& = 1 To UBound(var2, 2)
          var2(i&, j&) = ""
        Next j&
      End If
      Exit For
    End If
  Next k&
Next i&
R = var2
R.Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
lastLig& = S.[a65536].End(xlUp).Row
Set R = S.Range(S.Cells(2, 1), S.Cells(lastLig&, 6))
R.Copy
Sheets(FEUILLE).Activate
Set R = Range("a" & ActiveSheet.[a65536].End(xlUp).Row + 1 & "")
R.Select
ActiveSheet.Paste
Application.CutCopyMode = False
R.Select
Application.DisplayAlerts = False
S.Delete
Call LoginsEtMails
Erreur:
Application.DisplayAlerts = False
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox Err.Number & vbCrLf & Err.Description
End Sub

Sub LoginsEtMails()
Dim S As Worksheet
Dim R As Range
Dim var
Dim var2
Dim A$
Dim B$
Dim prenom$
Dim nom$
Dim i&
Dim j&
Dim cpt&
Dim lastLig&
Dim bool As Boolean
Set S = Sheets(FEUILLE)
lastLig& = S.[b65536].End(xlUp).Row
var = S.Range(S.Cells(1, 1), S.Cells(lastLig&, 6))
Set R = S.Range(S.Cells(1, 5), S.Cells(lastLig&, 6))
var2 = R
For i& = 1 To lastLig&
  nom$ = Cleaning(var(i&, 3))
  prenom$ = Cleaning(var(i&, 2))
    '--- Login ---
  A$ = Trim(var(i&, 5))
  If A$ = "" Then
    A$ = Left(nom$, 3) & Left(prenom$, 2)
    cpt& = 0
    Do
      B$ = A$
      If cpt& > 0 Then B$ = B$ & cpt&
      bool = False
      For j& = LBound(var2, 1) To UBound(var2, 1)
        If B$ = var2(j&, 1) Then
          bool = True
          cpt& = cpt& + 1
          Exit For
        End If
      Next j&
    Loop Until bool = False
    var2(i&, 1) = B$
  End If
    '--- Mail ---
  A$ = Trim(var(i&, 6))
  If A$ = "" Then
    A$ = prenom$ & "." & nom$
    cpt& = 0
    Do
      B$ = A$
      If cpt& > 0 Then B$ = B$ & cpt&
      bool = False
      For j& = LBound(var2, 1) To UBound(var2, 1)
        If B$ & DOMAINE = var2(j&, 2) Then
          bool = True
          cpt& = cpt& + 1
          Exit For
        End If
      Next j&
    Loop Until bool = False
    var2(i&, 2) = B$ & DOMAINE
  End If
Next i&
R = var2
End Sub

Private Function Cleaning(ByVal Chaine As String) As String
Dim i&
Dim NoChar
Dim Accent
NoChar = Array(" ", "", "'", "", "-", "")
Accent = Array("à", "a", "â", "a", "è", "e", "é", "e", "ê", "e", "ë", "e", _
        "î", "i", "ï", "i", "ô", "o", "ö", "o", "ù", "u", "û", "u", "ü", "u")
For i& = LBound(NoChar) To UBound(NoChar) Step 2
  Chaine = Replace(Chaine, NoChar(i&), NoChar(i& + 1))
Next i&
For i& = LBound(Accent) To UBound(Accent) Step 2
  Chaine = Replace(Chaine, Accent(i&), Accent(i& + 1))
Next i&
Cleaning = LCase(Chaine)
End Function

Cordialement.

PMO
Patrick Morange

 

[jeremie.pa]

Re : Besoin d'aide pour manipulation chaine de caractère.

bonjour,

Merci pour l'amélioration, cependant les utilisateurs de la source de donnée qui existent déjà sur la fiche test ne doivent pas être rapatrié !

Ils doivent être trié sur le matricule, s'il existe sur la fiche test il ne faut pas les rajouter alors qu'avec les tests que j'ai fait c'est toute la source de donnée qui est rajouté. En faite je ne peux faire que des imports de tout le monde et non les derniers.

j'ai beau essayer de comprendre votre code pour l'améliorer moi meme c'est incompréhensible ! Lol

En tout cas un grand merci pour le travail que vous m'avé déja fait c'est "magique" lol merci !

 

[PMO2]

Re : Besoin d'aide pour manipulation chaine de caractère.

Bonjour,

Voilà une nouvelle mouture dans laquelle il n'y a plus que la macro "ImportUtilisateurs" à lancer.
Elle appellera automatiquement la macro "LoginsEtMails".

La seule obligation est d'avoir une feuille (que j'appelle "test") comportant les titres suivants
matricule
Prénom
Nom
catégorie professionnel
login
mail

ATTENTION faites l'essai dans un nouveau classeur.

1) Faites une feuille "test" avec les titres susdits en A1:F1
2) Importez vos utilisateurs dans une feuille Excel (nom de la feuille "import")
3) Supprimez (pour l'essai) la moitié des lignes
4) Lancez la macro "ImportUtilisateurs" (les données renseignées des logins et mails doivent apparaître dans la feuille "test")
5) Importez à nouveau vos utilisateurs et mettez les données dans la feuille "import" préalablement effacée
6) Relancez la macro "ImportUtilisateurs". De nouvelles données sont renseignées sans que les données existantes n'aient changé

Une feuille de sauvegarde de la feuille "test" est créée (sous le nom Old test_x) pour pouvoir faire des vérifications.
Par la suite, à chaque nouvelle importation et si de nouveaux utilisateurs y figurent, de nouvelles données seront renseignées sans que les données existantes ne changent.

'### Adapter les constantes selon son usage ###
Const FEUILLE As String = "test"
Const DOMAINE As String = "@domaine.fr"
Const IMPORT As String = "import" 'dernière importation de la BDD
'##############################################

Sub ImportUtilisateurs()
Dim S As Worksheet
Dim S2 As Worksheet
Dim R As Range
Dim var
Dim var2
Dim lastLig&
Dim i&
Dim j&
Dim k&
Dim bool

For Each S In ActiveWorkbook.Sheets
  If S.Name = FEUILLE Then
    bool = True
    Exit For
  End If
Next S
If Not bool Then
  MsgBox "La feuille ''" & FEUILLE & "'' est introuvable."
  Exit Sub
End If

'/// Pour garder une trace de l'ancienne feuille test ///
On Error Resume Next
Sheets(FEUILLE).Copy before:=Sheets(1)
Do
  Err = 0
  i& = i& + 1
  ActiveSheet.Name = "Old " & FEUILLE & "_" & i&
Loop Until Err = 0
'////////////////////////////////////////////////////////

On Error GoTo Erreur
Application.ScreenUpdating = False
Sheets(FEUILLE).Copy after:=Sheets(Sheets.Count)
Set S = ActiveSheet
lastLig& = S.[a65536].End(xlUp).Row
Set R = S.Range(S.Cells(1, 1), S.Cells(lastLig&, 6))
R.Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
var = R
R.ClearContents
Application.DisplayAlerts = False
Sheets(IMPORT).Cells.Copy
S.[a1].Select
ActiveSheet.Paste
lastLig& = S.[a65536].End(xlUp).Row
Set R = S.Range(S.Cells(1, 1), S.Cells(lastLig&, 6))
R.Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
var2 = R
R.ClearContents
For i& = 2 To UBound(var2, 1)
  For k& = 2 To UBound(var, 1)
    If Trim(var2(i&, 1)) = Trim(var(k&, 1)) Then
      If Trim(var(k&, 5)) <> "" And Trim(var(k&, 6)) <> "" Then
        For j& = 1 To UBound(var2, 2)
          var2(i&, j&) = ""
        Next j&
      End If
      Exit For
    End If
  Next k&
Next i&
R = var2
R.Sort Key1:=[a1], Order1:=xlAscending, Header:=xlYes
lastLig& = S.[a65536].End(xlUp).Row
If lastLig& > 1 Then
  Set R = S.Range(S.Cells(2, 1), S.Cells(lastLig&, 6))
  R.Copy
  Sheets(FEUILLE).Activate
  Set R = Range("a" & ActiveSheet.[a65536].End(xlUp).Row + 1 & "")
  R.Select
  ActiveSheet.Paste
End If
Application.CutCopyMode = False
R.Select
S.Delete
Call LoginsEtMails
Erreur:
If Err = 9 Then
  S.Delete
  Call LoginsEtMails
ElseIf Err <> 0 Then
  MsgBox Err.Number & vbCrLf & Err.Description
End If
Application.DisplayAlerts = False
Application.ScreenUpdating = True
End Sub

Sub LoginsEtMails(Optional dummy As Byte)
Dim S As Worksheet
Dim R As Range
Dim var
Dim var2
Dim A$
Dim B$
Dim prenom$
Dim nom$
Dim i&
Dim j&
Dim cpt&
Dim lastLig&
Dim bool As Boolean
Set S = Sheets(FEUILLE)
lastLig& = S.[b65536].End(xlUp).Row
var = S.Range(S.Cells(1, 1), S.Cells(lastLig&, 6))
Set R = S.Range(S.Cells(1, 5), S.Cells(lastLig&, 6))
var2 = R
For i& = 1 To lastLig&
  nom$ = Cleaning(var(i&, 3))
  prenom$ = Cleaning(var(i&, 2))
    '--- Login ---
  A$ = Trim(var(i&, 5))
  If A$ = "" Then
    A$ = Left(nom$, 3) & Left(prenom$, 2)
    cpt& = 0
    Do
      B$ = A$
      If cpt& > 0 Then B$ = B$ & cpt&
      bool = False
      For j& = LBound(var2, 1) To UBound(var2, 1)
        If B$ = var2(j&, 1) Then
          bool = True
          cpt& = cpt& + 1
          Exit For
        End If
      Next j&
    Loop Until bool = False
    var2(i&, 1) = B$
  End If
    '--- Mail ---
  A$ = Trim(var(i&, 6))
  If A$ = "" Then
    A$ = prenom$ & "." & nom$
    cpt& = 0
    Do
      B$ = A$
      If cpt& > 0 Then B$ = B$ & cpt&
      bool = False
      For j& = LBound(var2, 1) To UBound(var2, 1)
        If B$ & DOMAINE = var2(j&, 2) Then
          bool = True
          cpt& = cpt& + 1
          Exit For
        End If
      Next j&
    Loop Until bool = False
    var2(i&, 2) = B$ & DOMAINE
  End If
Next i&
R = var2
End Sub

Private Function Cleaning(ByVal Chaine As String) As String
Dim i&
Dim NoChar
Dim Accent
NoChar = Array(" ", "", "'", "", "-", "")
Accent = Array("à", "a", "â", "a", "è", "e", "é", "e", "ê", "e", "ë", "e", _
        "î", "i", "ï", "i", "ô", "o", "ö", "o", "ù", "u", "û", "u", "ü", "u")
For i& = LBound(NoChar) To UBound(NoChar) Step 2
  Chaine = Replace(Chaine, NoChar(i&), NoChar(i& + 1))
Next i&
For i& = LBound(Accent) To UBound(Accent) Step 2
  Chaine = Replace(Chaine, Accent(i&), Accent(i& + 1))
Next i&
Cleaning = LCase(Chaine)
End Function

Cordialement.

PMO
Patrick Morange