Recherche de mot et reperage dans un fichier txt sous excel

**gandolfi** · 05/03/2018, 18h08

Bonjour,

Je dois gerer une liste d'adherents. je dois actualiser cette liste en fonction d'informations piochées dans un fichier pdf.
J'ai transformé ce pdf en txt et j'ai reussi à l'ouvrir sur excel.

Je voudrais maintenant recuperer des infos en me baladant dans ce fichier de 8 ko en faisant une boucle. Il y a la liste des adherents et des infos pas tres bien formatées.

- chercher "M." ou "MME" copier cette valeur dans une variable.
- Sur la meme ligne, recuperer les mots qui suivent "M." ou "MME" et précedent le mot "DPE". Ces mots sont séparés de plusieurs espaces hélas (nom prenom et parfois 2eme prenom)
- recuperer ensuite la ligne avec le caractere ">" s'il existe sinon s'arreter dès que l'on repere les caracteres "-------------"
- Puis recommencer la fonction pour passer aux ligne suivantes

Je ne sais pas si je m'y prend bien en faisant des transformation pdf --> txt --> excel
Je ne sais pas quelles fonctions utilisées

Merci pour votre aide

**Marc-L** · 05/03/2018, 18h12

Bonjour,

utiliser par exemple la recherche d'Excel, voir l'aide VBA interne de Range.Find et son exemple …

Sinon manipuler après avoir activé l'Enregistreur de macro : une base de code est livrée sur un plateau !

___________________________________________________________________________________________________________

Je suis Paris, Egypte, Nigeria, New-York, Mogadicio, Barcelone, London, Manchester, Stockholm, Istanbul, Berlin, Nice, Bruxelles, Charlie, …

**gandolfi** · 05/03/2018, 19h21

je n'ai jamais utilisé l'enregistreur de macro.

Le problème c'est qu'une seule colonne est utilisée. Et sur chaque ligne il y a des phrases et non pas une seule valeur par cellule.

MME Dupont ALICE NOELLE DPE TPD 7940115G X.C.C.PU CLAIRE LOUIS LA PLAINE DES LIANES
> 18 VG R OUEST (sur étab. 9740929S) TIT.R.RIG SS SPEC. 4076 TDP 10 7.800 B:1

j'ai commencé un bout de code mais il est vaiment degueu...
J'ai nettoyé la premiere ligne des espaces, puis je voudrais récuperer les 3dupon" "Alice" "Noelle" (cela peut varier si 2 prenom ou pas).
Je voudrais recuperer ensuite les infos de la ligne avec le ">" devant (18 et VG peuvent changer). " R OUEST (sur étab. 9740929S) TIT.R.RIG SS SPEC. 4076 TDP 10 7.800 B:1 "

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Sub Test()
    Dim Phrase As String
    Dim Index As Integer
    Dim Starter As Integer
    Dim Mot As String
    Dim a As Range
    Dim lig As Long
    Dim col As Long
    Dim inc As Integer
 
 
 
For lig = 3 To 40
 
If Cells(lig, 1).Value Like "*M.*" Or Cells(lig, 1).Value Like "*MME*" Then
 
Phrase = Cells(lig, 1).Value
'Phrase = "ttryt     tury  yuyy yyu   "
 
Phrase = LTrim(Phrase)
Phrase = RTrim(Phrase)
Phrase = Replace(Phrase, "      ", " ")
Phrase = Replace(Phrase, "     ", " ")
Phrase = Replace(Phrase, "    ", " ")
Phrase = Replace(Phrase, "   ", " ")
Phrase = Replace(Phrase, "  ", " ")
 
 
 
 
MsgBox Phrase
 ' Suppression des doubles espaces
    'Phrase = Trim(Me.desc_ang.Value)
 
      Starter = 1
    inc = 0
    Index = InStr(Starter, Phrase, " ")
    Do While inc >= 3
        Mot = Mid(Phrase, Starter, Index - Starter)
        MsgBox Mot
        MsgBox inc
        inc = inc + 1
        Starter = Index + 1
        Index = InStr(Starter, Phrase, " ")
    Loop
    End If
     Next lig
 
End Sub

**unparia** · 05/03/2018, 20h17

Bonjour

Le problème c'est qu'une seule colonne est utilisée. Et sur chaque ligne il y a des phrases et non pas une seule valeur par cellule.

Situation typique.
Plusieurs données distinctes dans un seul "champ" = aucune possibilité d'extraire avec assurance chacune des données = conception à revoir en amont.
Je comprends bien que tu as "pioché" ces données depuis un .pdf et que tu subis.
Mais dans ce cas : désolé -->> traiter cela informatiquement relève de l'utopie.

**patricktoulon** · 05/03/2018, 20h51

re

MME Dupont ALICE NOELLE DPE TPD 7940115G X.C.C.PU CLAIRE LOUIS LA PLAINE DES LIANES
> 18 VG R OUEST (sur étab. 9740929S) TIT.R.RIG SS SPEC. 4076 TDP 10 7.800 B:1

depuis quand excel ou vb possede un dictionnaire de nomprenom

comment veux tu quue excel ou vba devine ou commence et s'arrete le prenom

maintenant si tu me dis que ca commence toujours par Mr ou Mme ou Miss etc... et que apres le nom ce qui suit commence toujour par "DPE......"
alors la oui on peut effectivement faire quelque chose

sinon WALOUH WALOUH

Comme on te la dit revoir la conception en amont

**gandolfi** · 06/03/2018, 07h03

bonjour, merci pour vos réponses.
effectivement je subis le pdf....

la 1ere ligne qui m'interesse commence toujours par "M." ou "MME". c'est mon 1er repérage.
- Je veux recuperer le nom qui suit, le prenom et éventuellement le 3eme prenom s'il existe. Le deuxieme repérage c'est qu'il y a toujours les caracteres DPE avant le dernier prénom (meme parfois collé à la fin du prénom....)
MME DUPONT ALICE DPE TPD 7940115G X.C.C.PU CLAIRE LOUIS LA PLAINE DES LIANES
MME DUPONT ALICE NOELLEDPE TPD 7940115G X.C.C.PU CLAIRE LOUIS LA PLAINE DES LIANES
M. MARTIN GERARDDPE TPD 7940115G X.C.C.PU CLAIRE LOUIS LA PLAINE DES LIANES

- La deuxieme ligne qui m'interesse commence toujours par "> 2 chiffres 2 lettres". je dois récuperer ce qui se trouve après en rouge
> 18 VG R OUEST (sur étab. 9740929S) TIT.R.RIG SS SPEC. 4076 TDP 10 7.800 B:1

je pense que c'est un jeu de regex ou bien de fignolage en se repérant avec les caracteres avant et après. Mais ce n'est pas évident car je ne maitrise pas encore les fonctions.

**Pierre Fauconnier** · 07/03/2018, 21h50

Avec les règles énoncées, telles que je les ai comprises:

Les données en majuscules;
M. ou MME avec deux ou plusieurs espaces après (en fait, n'importe quoi comme premier mot);
Le groupe Nom avec les mots séparés par UN espace;
Au moins deux espaces entre le groupe Nom et le groupe Prénom;
Le groupe Prénom avec les mots séparés par UN espace;
Un ou plusieurs espaces entre le groupe Prénom et DPE.

Voici un pattern qui devrait fonctionner: ^(?:\w+\.?) {2,}(?:((?:\w+ )+) +((?:\w+ )+)) *DPE. Il permet de récupérer comme submatches uniquement les groupes Nom et Prénom (?: au début d'un groupe permet de ne pas le prendre dans les résultats).

C'est à toi d'adapter ce pattern aux données réelles que tu rencontres.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Test()
  Dim Cell As Range
  Dim Pattern As String
  Dim Matches As Object
  Dim i As Long
 
  Pattern = "^(?:\w+\.?) {2,}(?:((?:\w+ )+) +((?:\w+ )+)) *DPE"
 
  For Each Cell In Range("a1:a5")
    Set Matches = getRegExpMatches(Cell.Value, Pattern)
    Cell(1, 2).Value = Trim(Matches(0).SubMatches(0))
    Cell(1, 3).Value = Trim(Matches(0).SubMatches(1))
  Next
End Sub
 
Function getRegExpMatches(Value As String, Pattern As String) As Object
  Dim RegExp As VBScript_RegExp_55.RegExp
 
  Set RegExp = New VBScript_RegExp_55.RegExp
  RegExp.Pattern = Pattern
  RegExp.Global = True
  Set getRegExpMatches = RegExp.Execute(Value)
End Function

Nom : 2018-03-07_214930.png
Affichages : 215
Taille : 60,4 Ko

**unparia** · 07/03/2018, 22h01

Excusez-moi, mais je rappelle également ceci :

effectivement je subis le pdf....

Question toute bête : ce ".pdf" est-il "structuré" comme vous suggérez qu'il le soit pour être traité ?
Si tel n'est pas le cas, chercher à le structurer pour qu'il soit ainsi traitable ne fait que déplacer le problème puisque l'ajout d'un espace supplémentaire "là où il le faudrait" nécessiterait de déterminer préalablement ce "où" !

**gandolfi** · 08/03/2018, 10h24

Envoyé par Pierre Fauconnier

Avec les règles énoncées, telles que je les ai comprises:

Les données en majuscules;
M. ou MME avec deux ou plusieurs espaces après (en fait, n'importe quoi comme premier mot);
Le groupe Nom avec les mots séparés par UN espace;
Au moins deux espaces entre le groupe Nom et le groupe Prénom;
Le groupe Prénom avec les mots séparés par UN espace;
Un ou plusieurs espaces entre le groupe Prénom et DPE.

Voici un pattern qui devrait fonctionner: ^(?:\w+\.?) {2,}(?:((?:\w+ )+) +((?:\w+ )+)) *DPE. Il permet de récupérer comme submatches uniquement les groupes Nom et Prénom (?: au début d'un groupe permet de ne pas le prendre dans les résultats).

C'est à toi d'adapter ce pattern aux données réelles que tu rencontres.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Sub Test()
  Dim Cell As Range
  Dim Pattern As String
  Dim Matches As Object
  Dim i As Long
 
  Pattern = "^(?:\w+\.?) {2,}(?:((?:\w+ )+) +((?:\w+ )+)) *DPE"
 
  For Each Cell In Range("a1:a5")
    Set Matches = getRegExpMatches(Cell.Value, Pattern)
    Cell(1, 2).Value = Trim(Matches(0).SubMatches(0))
    Cell(1, 3).Value = Trim(Matches(0).SubMatches(1))
  Next
End Sub
 
Function getRegExpMatches(Value As String, Pattern As String) As Object
  Dim RegExp As VBScript_RegExp_55.RegExp
 
  Set RegExp = New VBScript_RegExp_55.RegExp
  RegExp.Pattern = Pattern
  RegExp.Global = True
  Set getRegExpMatches = RegExp.Execute(Value)
End Function

Merci pour ton super boulot. malheureusement j'ai un "type défini par l'utilisateur non défini" pour

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
Function getRegExpMatches(Value As String, Pattern As String) As Object
Dim RegExp As VBScript_RegExp_55.RegExp

**Pierre Fauconnier** · 06/03/2018, 11h48

Salut.

Tu pourrais utiliser les regex, éventuellement.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub Test()
  Dim Matches As Object
  Dim Elements
  Dim i As Long
  Dim Cell As Range
 
  For Each Cell In Range("a1:a2")
    Set Matches = GetRegExpMatches(Cell.Value, "^((.+) +)+DPE")
      If Matches.Count > 0 Then
        Elements = Split(Application.Trim(Matches(0).SubMatches(0)))
        For i = 0 To UBound(Elements)
          Cell(1, i + 2) = Elements(i)
        Next
      End If
  Next Cell
End Sub
 
Function GetRegExpMatches(Value As String, Pattern As String) As Object
  Dim regex As Object
  Dim Matches As Object
 
  Set regex = CreateObject("VBScript.RegExp")
  regex.Pattern = Pattern
  regex.Global = True
  Set GetRegExpMatches = regex.Execute(Value)
End Function

Si le pattern est rencontré, le tableau Elements reprend les mots se trouvant avant DPE. [EDIT] Code modifié pour tenir compte d'éventuels espaces en double ou en triple...[/EDIT]

Nom : 2018-03-06_123947.png
Affichages : 887
Taille : 5,3 Ko

Nom : 2018-03-06_123947.png
Affichages : 887
Taille : 5,3 Ko

**gandolfi** · 06/03/2018, 13h14

Merci pour toutes vos reponses.

- Pour l'instant je suis en train de tester la code de MArc. Mais il me manque le range pour selctionner les cellules dans le ARRAY et la maniere de recuperer tous les mots apres "> 2lettres 2chiffres" ( W(3) W(4) .....)

- Pour la solution de Pierre je vais regarder mais je ne sais pas comment assigner une valeur aux variable prenom1, prenom2, nom et le texte après "> 2lettres 2chiffres"

- La solution de Patrick est un peu compliqué pour moi

**gandolfi** · 07/03/2018, 14h52

Envoyé par Pierre Fauconnier

Salut.

Tu pourrais utiliser les regex, éventuellement.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub Test()
  Dim Matches As Object
  Dim Elements
  Dim i As Long
  Dim Cell As Range
 
  For Each Cell In Range("a1:a2")
    Set Matches = GetRegExpMatches(Cell.Value, "^((.+) +)+DPE")
      If Matches.Count > 0 Then
        Elements = Split(Application.Trim(Matches(0).SubMatches(0)))
        For i = 0 To UBound(Elements)
          Cell(1, i + 2) = Elements(i)
        Next
      End If
  Next Cell
End Sub
 
Function GetRegExpMatches(Value As String, Pattern As String) As Object
  Dim regex As Object
  Dim Matches As Object
 
  Set regex = CreateObject("VBScript.RegExp")
  regex.Pattern = Pattern
  regex.Global = True
  Set GetRegExpMatches = regex.Execute(Value)
End Function

Si le pattern est rencontré, le tableau Elements reprend les mots se trouvant avant DPE. [EDIT] Code modifié pour tenir compte d'éventuels espaces en double ou en triple...[/EDIT]

Nom : 2018-03-06_123947.png
Affichages : 887
Taille : 5,3 Ko

Mon code fonctionne à peu près mais je me retrouve devant un souci avec des noms composés (DE LA HOGUE). Je récupere DE comme nom et LA comme prénom

MME DE LA HOGUE GISELE DPEA REA 970625L E.F.PU ROLAND JASMINI
MME DE LA HOGUE GISELE MARIE DPEA REA 970625L E.F.PU ROLAND JASMINI
M. DE LA HOGUE JEAN-LOUIS DPEA REA 970625L E.F.PU ROLAND JASMINI
M. DUPONT JEAN LOUIS DPEA REA 970625L E.F.PU ROLAND JASMINI

J'ai remarqué qu'il y avait toujours :
- Un espace de 2 entre MME et le nom (MME DE)
- Un espace de 3 avec M. et le nom (M. DE LA HOGUE).
- Un espace de 1 pour séparer les composantes du nom ou des prénoms (DE LA HOGUE, GISELE MARIE)

J'étudie la possibilité d'un REGEX.
- Sélectionner le nom (situé 2 ou 3 caractères après MME ou M.) qui est représenté par un seul groupe tous les mots séparés par seulement 1 espace (DE LA HOGUE) ou le seul mot (DUPONT)
- Selectionner le prénom qui est représenté par un seul mot (GISELE, JEAN-LOUIS) ou un groupe de mot séparés d'un seul espace (JEAN LOUIS, GISELE MARIE).
- Assigné le premier groupe à la variable "nom" et le deuxieme groupe à la variable "prenom"

Helas je connais tres peu les Regex et les exemples sont dur à appliquer. J'ai recuperer une base mais je bloque completement.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
SUB TRI()
Dim reg As Object
Dim txt As String
Dim texte As String
 
Set reg = CreateObject("vbscript.regexp")
 
texte = " MME  DE LA HOGUE         MARIE GISELE        DPEGDI REA 970625L  E.F.PU ROLAND JASMINI  "
 
 reg.Pattern = ""
 txt = reg.Replace(texte, "")
 
nom = $1                     ' DE LA HOGUE
prenom = $2                'MARIE GISELE
 
 
End SUB

**Pierre Fauconnier** · 08/03/2018, 20h30

Soit tu les mémorises dans des variables ou des cellules, soit tu concatènes les lignes qui correspondent à la même info et tu composes ton pattern regexp pour la ligne entière, avec les groupes Nom et Prénom puis le DPE... puis le > et les groupes à extraire à la suite du >

Perso, je recomposerais la chaine complète pour la tester en RegExp avec un seul jeu de Matches pour la ligne de données complète, pour autant que tes lignes respectent un pattern (=> pour autant qu'un pattern soit exprimable pour ces lignes)

**gandolfi** · 09/03/2018, 12h01

merci beaucoup j'avance à grand pas mais c'est une usine à gaz

il me manque la recursivité pour chercher les personnes avec meme nom (colonne 1) mais avec differents prenoms. sinon cela s'arret au premier nom et ne va pas chercher les eventuel autre nom plus bas pour comparer le prenom.
J'ai trouvé un code mais cela ne fonctionne pas.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
    Set Destination = ThisWorkbook.Sheets("voeux")
    Set MaSource = Workbooks.Open(adherents)
    Set Source = Workbooks(MaSource.Name).Sheets("Liste")
 
With Worksheets(P:\z-INFORMATIQUE\TEST\ADHERENTS.xlsm).Range("a3:a2000")
Set Trouve = Source.Columns(1).Find(nomcompare, LookAt:=xlWhole)
     If Not Trouve Is Nothing Then
        position = Trouve.Row
do
....
        Set Trouve = .FindNext(Trouve)
        Loop While Not c Is Nothing
       END IF
 
end with

**gandolfi** · 09/03/2018, 20h11

j'ai beau essayer je seche. j'ai du code inutile et mal tourné je pense.
Dans mon tableau adherents la colonne 1 est pour les nom et la colonne 2 pour les prenoms. Je voudrais trouver le nom dans la colonne 1 puis comparer avec le prenom sur la meme ligne colonne 2. Mais je voudrais faire cela meme s'il existe plusieurs fois le meme nom et ainsi derouler la liste en comparant le prenom à chaque fois.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
Sub Valeur_cherchee(nom As String, prenom As String, affectation As String, communeaff As String, ecoleaff As String, posteaff As String, pointaff As String, speaff As String)
Dim Destination As Worksheet, nomcompare As String, m_rnFind As Range, MaSource As Workbook, Source As Worksheet, i As Long, Trouve As Range, Trouve2 As String, position As Integer, position2 As Integer, adherents As String
 
 adherents = "P:\z-INFORMATIQUE\TEST\ADHERENTS.xlsm"
 
    Set Destination = ThisWorkbook.Sheets("voeux")
    Set MaSource = Workbooks.Open(adherents)
    Set Source = Workbooks(MaSource.Name).Sheets("Liste")
 
Workbooks.Open (adherents)
Worksheets("Liste").Activate
 
'Application.ScreenUpdating = False
 
Set Trouve = Range("A1:A1000").SpecialCells(xlCellTypeConstants)
 
      nomcompare = Replace(nom, "-", " ")
 
With Trouve
    Set m_rnFind = .Find(What:=nomcompare)
 
      'Set Trouve = .Find(nomcompare, After:=.Range("A2"), LookIn:=xlValues)
 
 
       'If Not Trouve2 Is Nothing And Not Trouve Is Nothing Then
    If Not m_rnFind Is Nothing Then
 
        Do
        position = Trouve.Row
        p = m_rnFind.Address
 
        Trouve2 = Sans_accent(Cells(position, 2).Value)
        Trouve2 = UCase(Cells(position, 2).Value)
        prenom = Replace(prenom, " ", "-")
 
            If Trouve2 = prenom Then
 
            '            Cells(position, 24).Value = affectation
Cells(position, 24).Value = ecoleaff
Cells(position, 25).Value = communeaff
Cells(position, 26).Value = posteaff
Cells(position, 27).Value = speaff
Cells(position, 28).Value = pointaff
 
 ActiveWorkbook.Close True
 
            End If
 
 Set m_rnFind = .FindNext(m_rnFind)
Loop While Not m_rnFind Is Nothing
Else
            'lire = Trouve.Offset(, 2)
            'MsgBox "La Valeur prenom " & prenom & " n'a pas été trouvée"
            ActiveWorkbook.Close True
            icherche = icherche + 1
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 1).Value = nom
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 2).Value = prenom
           ' Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 3).Value = affectation
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 3).Value = ecoleaff
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 4).Value = communeaff
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 5).Value = posteaff
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 6).Value = speaff
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 7).Value = pointaff
 
            icherche = icherche + 1
 
End If
 
 
End With
   ' Next
Application.ScreenUpdating = True
       ' Set Destination = Nothing: Set MaSource = Nothing: Set Source = Nothing
Workbooks("voeux.xlsm").Sheets("voeux").Activate
       ' Workbooks("ADHERENTS.xlsm").Close savechanges:=True
End Sub

MErci pour votre aide

**gandolfi** · 10/03/2018, 21h03

Tout marche . Merci beaucoup !!!!!!!!!

Par contre j'ai un probleme logiciel avec EXCEL. Je dois analyser pres de 200.000 lignes . Au bout d'un moment excel plante. les fenetres se grisent et plus rien ne repond meme pas en faisant pause pour la macro... 32 Mo sont utilisés par excel 2010 sur windows et 32% processeur.

Avez vous des pistes ?

je vous donne mon code "sale ". Il est fonctionnel mais pas optimisé du tout. J'ai honte..... j'utilise des Goto il parait que c'est pas bon.

module 1

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
   Dim nom As String, prenom As String, code As String, ecole As String, commune As String, i As Integer
    Dim ecoleaff As String, pointaff As String, posteaff As String, communeaff As String, affectation As String, speaff As String
 
Sub regEx()
    Dim Phrase As String, Phrase2 As String, Index As Integer, Pattern As String, nom2 As String, activite As Integer
    Dim lig As Long
 
 
Application.ScreenUpdating = False
For lig = 36 To 21313
'For lig = 21216 To 25313
'MsgBox Cells(lig, 1).Value
'''''''' TEST POUR LE NOM ET PRENOM
If Cells(lig, 1).Value Like " M.*" Or Cells(lig, 1).Value Like " MME*" Then
 
'' test si pas de voeux ou erreur ou continue
 
     If nom <> "" And affectation <> "" Then
 
        'MsgBox "nom :" & nom & " prenom :" & prenom & " code" & code & " ecole " & ecole & " commune " & commune & " affectation " & affectation
Call Valeur_cherchee(nom, prenom, affectation, communeaff, ecoleaff, posteaff, pointaff, speaff)
nom = ""
prenom = ""
code = ""
ecole = ""
affectation = ""
commune = ""
communeaff = ""
ecoleaff = ""
posteaff = ""
pointaff = ""
speaff = ""
 
GoTo suite
 
     Else
                If nom <> "" And affectation = "" Then
 
                    affectation = "Aucun"
                    communeaff = "rien"
                    ecoleaff = "rien"
                    posteaff = "rien"
                    pointaff = "rien"
                    speaff = "rien"
 
                    'MsgBox "nom :" & nom & " prenom :" & prenom & " code" & code & " ecole " & ecole & " commune " & commune & " affectation " & affectation
                    Call Valeur_cherchee(nom, prenom, affectation, communeaff, ecoleaff, posteaff, pointaff, speaff)
 
nom = ""
prenom = ""
code = ""
ecole = ""
affectation = ""
commune = ""
communeaff = ""
ecoleaff = ""
posteaff = ""
ptaff = ""
GoTo suite
                Else
                            If nom = "erreur" Then
                            i = i + 1
                            ThisWorkbook.Sheets("HS").Cells(i, 1).Value = Phrase
                            Workbooks("voeux.xlsm").Sheets("voeux").Activate
                            End If
nom = ""
prenom = ""
code = ""
ecole = ""
affectation = ""
commune = ""
communeaff = ""
ecoleaff = ""
posteaff = ""
pointaff = ""
speaff = ""
 
GoTo suite
                End If
 
suite:
 
Phrase = Cells(lig, 1).Value
Phrase = Replace(Phrase, " DPE", "  DPE")
Phrase = Replace(Phrase, " ST ", "  ST ")
Phrase = Replace(Phrase, " SEGPA ", "  SEGPA ")
Phrase = Replace(Phrase, " E.E.", "  E.E.")
Phrase = Replace(Phrase, " E.M.", "  E.M.")
Phrase = Replace(Phrase, " IEN ", "  IEN ")
Phrase = Replace(Phrase, "  CLG", " CLG")
Phrase = Replace(Phrase, "ENS.CL.ELE ", "ENS.CL.ELE  ")
Phrase = Replace(Phrase, "ENS.CL.MA ", "ENS.CL.MA  ")
 
 
        If Cells(lig, 1).Value Like "* ACTIVITE *" Then
 
activite = 1
            Pattern = "(?:\s)(?:\w+\.?) {2,}(?:((?:[-A-Z]+ )+) +((?:[-A-Z]+ )+) +((?:[-A-Z]+ )+))"
 
'Phrase = Application.Trim(Cells(lig, 1).Value)
'If inc = 2 Then nom = Mot
'If inc = 3 Then prenom1 = Mot
'If inc = 4 Then prenom2 = Mot
'If prenom2 Like "DPE*" Then prenom2 = ""
'prenom1 = PartieGauche(prenom1, "DPE")
'prenom2 = PartieGauche(prenom2, "DPE")
'If prenom1 Like "*DPE*" Then prenom2 = ""
'prenom = prenom1 & prenom2
 
 
            Call regnom(Phrase, Pattern, activite)
 
        Else
 
Pattern = "(?:\s)(?:\w+\.?) {2,}(?:((?:[-A-Z]+ )+) +((?:[-A-Z]+ )+) +((?:[A-Z0-9]+ )+) +((?:[-A-Z0-9.’]+ )+) +((?:[-A-Z0-9.]+ )+))"
 
activite = 0
Call regnom(Phrase, Pattern, activite)
 
nom2 = nom
 
        End If
 
 
 
'Phrase = Application.Trim(Cells(lig, 1).Value)
 
'        If inc = 2 Then nom = Mot
 '       If inc = 3 Then prenom1 = Mot
  '      If inc = 4 Then prenom2 = Mot
 
 '     If prenom2 Like "DPE*" Then prenom2 = ""
' prenom1 = PartieGauche(prenom1, "DPE")
' prenom2 = PartieGauche(prenom2, "DPE")
 'If prenom1 Like "*DPE*" Then prenom2 = ""
 
 
End If
End If
 
If Cells(lig, 1).Value Like ">*" Then
Phrase2 = Cells(lig, 1).Value
Phrase2 = Replace(Phrase2, "SEGPA  OPTION", "SEGPA OPTION")
Phrase2 = Replace(Phrase2, "SANS SPEC.", " SANS SPEC. ")
Phrase2 = Replace(Phrase2, " ST ", "  ST ")
Phrase2 = Replace(Phrase2, " SEGPA ", "  SEGPA ")
Phrase2 = Replace(Phrase2, " E.E.", "  E.E.")
Phrase2 = Replace(Phrase2, " E.M.", "  E.M.")
Phrase2 = Replace(Phrase2, " IEN ", "  IEN ")
Phrase2 = Replace(Phrase2, " IEN     TAMPON", " IEN TAMPON")
Phrase2 = Replace(Phrase2, "  CLG", " CLG")
Phrase2 = Replace(Phrase2, "ENS.CL.ELE ", "ENS.CL.ELE  ")
Phrase2 = Replace(Phrase2, "ENS.CL.MA ", "ENS.CL.MA  ")
Phrase2 = Replace(Phrase2, ".MEN ", ".MEN  ")
Phrase2 = Replace(Phrase2, "(sur", " (sur")
 
'Pattern = "(?:\>) (?:\w+) (?:\w+) +((?:[-A-Z0-9.’]+ )+) +((?:[-A-Z0-9.’]+ )+) +((?:[-A-Z0-9.’]+ )+) +(?:\w+) (?:\w+) (?:\w+) +([0-9.]+)"
'Pattern = "(?:\>) (?:\w+) (?:\w+) (?:\w+) +((?:[-A-Z0-9.’]+ )+) +((?:[-A-Z0-9.’]+ )+)  +((?:[-A-Z0-9.’]+ )+) +((?:[-A-Z0-9.’]+ )+) +((?:[-A-Z0-9.’]+ )+) +([0-9.]+)"
'Pattern = "(?:\>) (?:\w+) (?:\w+) (?:\w+) +((?:[-a-zA-Z0-9.-é\(\)]+ )+) +((?:[-A-Z0-9.’]+ )+) +((?:[-A-Z0-9.’]+ )+)+((?:[-A-Z0-9.’]+ )+) +((?:[-A-Z0-9.’]+ )+) +([0-9.]+)"
Pattern = "(?:\>) (?:\w+) (?:\w+) (?:\w+) +((?:[-A-Za-z0-9.’\(\)]+ )+) +((?:[-A-Za-z0-9.’é\(\)]+ )+)  +((?:[-A-Z0-9.’]+ )+) +((?:[-A-Z0-9.’]+ )+) +((?:[-A-Z0-9.’]+ )+) +([0-9.]+)"
 
 
activite = 2
Call regnom(Phrase2, Pattern, activite)
 
End If
 
     Next lig
 
Application.ScreenUpdating = True
 
 
End Sub
 
 
Function regnom(Phrase As String, Pattern As String, activite As Integer)
  'Dim nom As String, prenom As String, code As String, commune As String
  Dim Matches As Object
 
 
    Set Matches = getRegExpMatches(Phrase, Pattern)
    If Matches.Count > 0 Then
 
             If activite = 1 Then
            nom = Trim(Matches(0).SubMatches(0))
            prenom = Trim(Matches(0).SubMatches(1))
              code = Trim(Matches(0).SubMatches(2))
 
            End If
 
             If activite = 0 Then
 
             nom = Trim(Matches(0).SubMatches(0))
             prenom = Trim(Matches(0).SubMatches(1))
              code = Trim(Matches(0).SubMatches(2))
              ecole = Trim(Matches(0).SubMatches(3))
             commune = Trim(Matches(0).SubMatches(4))
 
             End If
 
              If activite = 2 Then
 
             ecoleaff = Trim(Matches(0).SubMatches(0))
             communeaff = Trim(Matches(0).SubMatches(1))
                      posteaff = Trim(Matches(0).SubMatches(2))
                      speaff = Trim(Matches(0).SubMatches(3))
             pointaff = Trim(Matches(0).SubMatches(5))
 
 affectation = ecoleaff & communeaff & posteaff & speaff & pointaff
 
             End If
 
 
    Else
    nom = "erreur pat"
 
    End If
    'Cell(1, 2).Value = Trim(Matches(0).SubMatches(0))
Application.ScreenUpdating = True
End Function
 
Function getRegExpMatches(Value As String, Pattern As String) As Object
  Dim RegExp As Object
 
  Set RegExp = CreateObject("VBScript.RegExp")
  RegExp.Pattern = Pattern
  'RegExp.Global = True
  Set getRegExpMatches = RegExp.Execute(Value)
End Function

module 2

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
Dim icherche As Integer
 
Sub Valeur_cherchee(nom As String, prenom As String, affectation As String, communeaff As String, ecoleaff As String, posteaff As String, pointaff As String, speaff As String)
Dim Destination As Worksheet, nomcompare As String, m_rnFind As Range, MaSource As Workbook, Source As Worksheet, i As Long, Trouve As Range, Trouve2 As String, position As Integer, position2 As Integer, adherents As String
 
 adherents = "D:\INFORMATIQUE\FO word excel\TEST\ADHERENTS.xlsm"
 
'    Set Destination = ThisWorkbook.Sheets("voeux")
 '   Set MaSource = Workbooks.Open(adherents)
  '  Set Source = Workbooks(MaSource.Name).Sheets("Liste")
 
'Workbooks.Open (adherents)
'Worksheets("Liste").Activate
 
Workbooks("ADHERENTS.xlsm").Sheets("Liste").Activate
 
Application.ScreenUpdating = False
 
Set Trouve = Range("A1:A1000").SpecialCells(xlCellTypeConstants)
 
      nomcompare = Replace(nom, "-", " ")
 
With Trouve
    Set m_rnFind = .Find(What:=nomcompare)
 
      'Set Trouve = .Find(nomcompare, After:=.Range("A2"), LookIn:=xlValues)
       'If Not Trouve2 Is Nothing And Not Trouve Is Nothing Then
    If Not m_rnFind Is Nothing Then
 
        m_stAddress = m_rnFind.Address
 
repete:
'    Do
        position = m_rnFind.Row
        'p = m_rnFind.Address
 
        Trouve2 = Sans_accent(Cells(position, 2).Value)
        Trouve2 = UCase(Cells(position, 2).Value)
        prenom = Replace(prenom, " ", "-")
 
            If Trouve2 = prenom Then
 
            '            Cells(position, 24).Value = affectation
            Cells(position, 24).Value = ecoleaff
            Cells(position, 25).Value = communeaff
            Cells(position, 26).Value = posteaff
            Cells(position, 27).Value = speaff
            Cells(position, 28).Value = pointaff
 
                     Application.ScreenUpdating = True
          ' ActiveWorkbook.Save
           ' ActiveWorkbook.Close True
 
            'GoTo DoneFinding
 
            Else
 
Set m_rnFind = .FindNext(m_rnFind)
 
                    If m_rnFind Is Nothing Then
                    GoTo DoneFinding
                    Else
                    GoTo repete
                    End If
 
            End If
 
 
Else
DoneFinding:
            'lire = Trouve.Offset(, 2)
            'MsgBox "La Valeur prenom " & prenom & " n'a pas été trouvée"
                       Application.ScreenUpdating = True
            'ActiveWorkbook.Close True
' ActiveWorkbook.Save
            icherche = icherche + 1
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 1).Value = nom
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 2).Value = prenom
           ' Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 3).Value = affectation
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 3).Value = ecoleaff
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 4).Value = communeaff
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 5).Value = posteaff
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 6).Value = speaff
            Workbooks("voeux.xlsm").Sheets("AUTRES").Cells(icherche, 7).Value = pointaff
 
 
 End If
End With
 
 
   ' Next
 
       ' Set Destination = Nothing: Set MaSource = Nothing: Set Source = Nothing
Workbooks("voeux.xlsm").Sheets("voeux").Activate
       ' Workbooks("ADHERENTS.xlsm").Close savechanges:=True
End Sub
 
Function Sans_accent(Chaine As String) As String  ' R. Dezan + Michel Pierron || adaptée et commentée par D. IBKA
 
' remplacement des caractères accentués par leur équivalent sans accent
 
 Dim ListeDesAccents As String
 Dim ListeSansAccent As String
 Dim i As Integer
 Dim u As Integer
 
 ' on va utiliser deux listes de correspondance (avec et sans accent)
 ' chaque caractère accentué a une position définie dans la liste des accents
 ' son équivalent sans accent a la même position dans la liste sans accent
 
 ListeDesAccents = "ÀÁÂÃÄÅÈÉÊËÌÍÎÏÑÒÓÔÕÖÙÚÛÜÝàáâãäåèéêëìíîïðñòóôõöùúûüýÿ"
 ListeSansAccent = "AAAAAAEEEEIIIINOOOOOUUUUYaaaaaaeeeeiiiionooooouuuuyy"
 
 
 ' pour chaque caractère de la chaine testée
 For i = 1 To Len(Chaine)
 
    ' on cherche si le caractère fait partie de la liste des caractères accentués
    u = InStr(1, ListeDesAccents, Mid(Chaine, i, 1), 0)
 
    ' si c'est le cas, on le remplace par son équivalent non accentué
    If u Then
        Mid(Chaine, i, 1) = Mid(ListeSansAccent, u, 1)
    End If
 
 Next i
 
 ' on retrouve à la fin : une chaîne convertie sans les accents
 Sans_accent = Chaine
 
End Function

**Pierre Fauconnier** · 06/03/2018, 13h25

En fait, même pas besoin de regex.

Si j'ai bien compris que tes lignes commencent systématiquement par une mention civile (mr, mme, mlle, ...) puis par le nom et les prénoms avec x espaces entre puis x espaces puis DPE, tu peux utiliser le code suivant, le tableau elements te donnant en (0) le terme civil, le (1) le nom et les suivants les prénoms... (Je les ai mis dans des cellules, mais tu en fais ce que tu veux)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub Test()
  Dim Cell As Range
  Dim Pos As Long
  Dim Elements
  Dim i As Long
 
  For Each Cell In Range("a1:a2")
    Pos = InStr(1, Cell.Value, "DPE", vbTextCompare)
    If Pos > 0 Then
      Elements = Split(Application.Trim(Left(Cell.Value, Pos - 1)), " ")
      For i = 0 To UBound(Elements)
        Cell(1, i + 2).Value = Elements(i)
      Next i
    End If
  Next
End Sub

Envoyé par gandolfi

[...]je ne sais pas comment assigner une valeur aux variable prenom1, prenom2[...]

Perso, je ne jouerais pas avec des variables prenom1, prenom2 puisque tu pourrais en avoir plusieurs. C'est l'intérêt du SPLIT qui crée un tableau avec le nombre voulu d'éléments. Si ton tableau contient 3 élements, c'est que la personne n'a qu'un prénom (Titre civil, Nom, prénom). Si ton tableau contient 5 éléments, c'est que la personne a trois prénoms (titre civil, nom, prénom1, prénom2, prénom3)

Invité · 07/03/2018, 15h43

Bonjour Pierre,

j'ai fait le même travail (avec un collègue qui effectuait la même chose en parallèle) pour une casse de retraite il y une vingtaine d'années, et sur plusieurs milliers d'assuré nous sommes tombé sur un écart de 3 que nous avons géré manuellement!

dans notre base (Access pour le coup) nous avion une table civilité (Mme,Mis,M,Msr) .une table particule,Article (De,Da,Le L',La) etc...

on commence de gauche à droite,on test Iscivilité si oui on écrit colonne A; si IsTitreParticule on écrit en B, on considère le premier prénom comme un nom si si rien nous indique qu'il en est autrement; à la fin des prénom on considère comme adresse! la chose se complique si on décompose l'adress1 Adres2 Cp etc...

bien sur un nom composé de plusieurs prénoms peut se voir syndiqué en deux mais le courrier arrivera de toute les façon on est jamais sur d'un résulta parfait!

http://www.les-abreviations.com/civilite.html pour la france

Invité · 06/03/2018, 14h24

Bonjour,

je suis pas certain d'avoir compris, je jette comme ça !

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
Public Cn As Object
Sub test()
Set Cn = OpenConnetion(ThisWorkbook.Path & "\Prénom.xlsx", True)
Dim T, FinPnom As Boolean
ThisWorkbook.Sheets("Feuil1").Range("B:E").Clear
Set r = ThisWorkbook.Sheets("Feuil1").Range("A1").CurrentRegion
For i = 2 To r.Rows.Count
FinPnom = False
    T = Split(Application.Trim(r(i, 1).Text) & Space(10))
    r(i, 1).Offset(0, 1) = T(0): r(i, 1).Offset(0, 2) = T(1)
    For x = 2 To UBound(T)
    If Trim("" & T(x)) = "" Then Exit For
        If IsPrenom(Trim("" & T(x))) And Not FinPnom Then
         If Trim("" & r(i, 1).Offset(0, 3)) = "" Then r(i, 1).Offset(0, 3) = T(x) Else r(i, 1).Offset(0, 3) = r(i, 1).Offset(0, 3) & "-" & T(x)
        Else
            FinPnom = True
            If Trim("" & r(i, 1).Offset(0, 4)) = "" Then r(i, 1).Offset(0, 4) = T(x) Else r(i, 1).Offset(0, 4) = Trim(r(i, 1).Offset(0, 4)) & " " & T(x)
        End If
    Next
Next
End Sub
Public Function OpenConnetion(FichierXls As String, AvecTitre As Boolean) As Object
'ouvre la connexion au fichier Excel
'FichierXls non et chemin complet du fichier
'AvecTitre précise si la première ligne de l'onglet est les entête de colonnes ou pas
'rzutourne la connexion
On Error Resume Next
Dim HDR
If Dir(FichierXls) = "" Then MsgBox FichierXls & vbCrLf & "Pas trouvé": Exit Function ' versifie si le fichier existe
HDR = Array("No", "Yes")
Set OpenConnetion = CreateObject("ADODB.Connection") 'Instancie un objet adosb c'est mieux que d'utiliser le références
With OpenConnetion
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & FichierXls & ";Extended Properties=""Excel 12.0 Xml;HDR=" & HDR(Abs(AvecTitre)) & ";IMEX=1;"""
        .Open
        If Err Then
            MsgBox Err.Description
            Set OpenConnetion = Nothing
        End If
        Err.Clear
        On Error GoTo 0
End With
End Function
Public Function OpenRecordSet(Sql, Cn As Object) As Object 'Retourne un recordset
'Retourne un RecordeSet
On Error Resume Next
Set OpenRecordSet = CreateObject("ADODB.Recordset")
OpenRecordSet.Open Sql, Cn, 1, 3 'ouvre un recordset sur la requête SQL pour la connexion en lecteur écriture et ajou dynamique
If Err Then
    MsgBox Err.Description
Set OpenRecordSet = Nothing
End If
Err.Clear
On Error GoTo 0
End Function
Public Function IsPrenom(Pnm As String) As Boolean
Dim Rs As Object
Set Rs = OpenRecordSet("select * from [Prénom$] Where [Prénom]='" & Replace(Pnm, "'", "''") & "'", Cn)
IsPrenom = Not (Rs.EOF)
Rs.Close: Set Rs = Nothing
End Function