Discussion :

[Invité]

oui c'est vrai!

si les espaces peuvent indiquer les groupe auquel appartient une série de mots un split séparé par 1,2,3 espace!

j’avoue ne pas avoir pisté le regexp, mais oui!

[gandolfi]

effectivement j'ai verifié les espaces et cela va permettr de délimiter les nom, prenom, et autres groupes d'infos

que pensez vous de mon regex ?
avez vous des pistes ?

merci

[unparia]

Les difficultés découvertes ne sont ni plus ni moins que celles que j'avais signalées (mes messages 7 et 12 restés sans réactions)

[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

[unparia]

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]

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]

Sorry.

Pour éviter de devoir référencer la librairie, il vaut mieux travailler en late binding.

Tu peux remplacer le code de la fonction par celui-ci:

Code :

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

1
2
3
4
5
6
7
8
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

[gandolfi]

Argument ou appel de procedure incorrect

Cell(1, 2).Value = Trim(Matches(0).SubMatches(0))

[gandolfi]

Il y avait un soucis en amont dans la preparation du texte. Cela fonctionne Merci Beaucoup

Je vais essayer de comprendrer ton REGEX mais c'est pas gagné.

Il me reste à pouvoir capturer les nom ou prenom séparés par un "-" au lieu d'un espace et les sous groupes derriere DPE qui sont séparés par au moins 2 espaces entre eux.

[patricktoulon]

re
quand je pense que le nom de famille composé n'a meme pas été abordé ni meme envisagé

comment un split(split(texte,"mr" ou "mme")(1),"DPE")(0) peut devenir aussi compliqué et meme le split(texte,">")(1) d'ailleurs

[Pierre Fauconnier]

Gandolfi,

Le pattern suivant récupère les noms ou prénoms composés: ^(?:\w+\.?) {2,}(?:((?:[-A-Z]+ )+) +((?:[-A-Z]+ )+)) *DPE
Ce n'est pas compliqué. Il suffit de modifier le pattern pour s'adapter au cas voulu. On pourrait envisager les caractères accentués, par exemple. C'est là toute la force des regexp. Ca permet en plus de pas mettre la logique métier en dur dans le code.




Pourrais-tu rendre un exemple de ce que tu souhaites extraire après les groupes Nom et Prénom?

[gandolfi]

MERCI BEAUCOUP PIERRE.

Grace à toi et en tatonnant j'ai trouvé ce REGEX qui s'adapte à pas mal de situation. je recupere ainsi 5 sous groupes.

(?:\s)(?:\w+\.?) {2,}(?:((?:[-A-Z]+ )+) +((?:[-A-Z]+ )+) +((?:[A-Z0-9]+ )+) +((?:[A-Z.]+ )+) +((?:[-A-Z0-9.]+ )+))

-Il me reste donc à nettoyer devant DPE en ajoutant 2 espaces (il peu arrivé qu'il soit collé avec un prénom).
- Rajouter 2 espaces devant " ST "
- Pour les lignes débutant par M. ou MME mais pour lesquelles le Regex ne trouve rien car elles sont trop particulieres --> les écrire sur une autre feuilles les unes à la suite des autres pour une analyse manuelle

[gandolfi]

j'avance

dans la fonction que tu m'a donné et que j'ai un peu modifié. comment faire en sorte que
- si le pattern ne correspond pas, il continue sans beuggué ? en affectant nom = "" affectation = ""
- Qu'il renvoi le svaleurs dans mon sub principal et que ses valeurs restent enregistrées ? En effet elle s'effacent dès que j'explore une autre ligne.

j'appelle la fonction --> Call regnom(Phrase, Pattern) dans ma fonction principale

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
Sub regnom(Phrase As String, Pattern As String)
  Dim nom As String, prenom As String, code As String, commune As String
  Dim Matches As Object
 
  'Pattern = "(?:\s)(?:\w+\.?) {2,}(?:((?:[-A-Z]+ )+) +((?:[-A-Z]+ )+) +((?:[A-Z0-9]+ )+) +((?:[A-Z.]+ )+) +((?:[-A-Z0-9.]+ )+))"
 
    Set Matches = getRegExpMatches(Phrase, Pattern)
    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 Sub
 
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

[Pierre Fauconnier]

Pour ne pas que ça plante si la chaine ne correspond pas au modèle

Code :

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

1
2
3
4
5
6
 
Set Matches = getRegExpMatches(Phrase, Pattern)
if matches.count>0 then
  ...
  ...
endif

Pas compris ta question sur le fait de changer de ligne

[gandolfi]

Pour ne pas que ça plante si la chaine ne correspond pas au modèle

Code :

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

1
2
3
4
5
6
 
Set Matches = getRegExpMatches(Phrase, Pattern)
if matches.count>0 then
  ...
  ...
endif

Pas compris ta question sur le fait de changer de ligne

en fait il me trouve les valeurs nom, prenom... mais ensuite les variables sont reunitialisés dès qu'il analyse une autre ligne du pdf. je voudrais les garder en memoire et les reinitialiser quand il a unscrit les donnees dans le fichier.

peut ete en les ecrivant dans une cellule temporaire ?

[Pierre Fauconnier]

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]

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]

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]

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

[patricktoulon]

32 mega de memoire utilisée par tes tableaux regex et/ou split et cela avec en plus chaque allocation de memoire en lecture et ecriture
ca t'etonne toi le white screen? pas moi
je pourrais avoir un exemplaire avec juste une 20aines lignes avec tes cas les plus compliqués