Discussion :

[mimich_88]

Bonjour,
j'écris une fonction pour copier les colonnes d'un onglet vers un autre et j'aimerai copier l'email qui est entre deux crochets, par exemple : Toto Isabelle<t.isabelle@gmail.com> j'aimerai extraire que la valeur t.isabelle@gmail.com et la copier dans un autre onglet

voici le code :

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
Function columnLookup(Name As String, Line As Range) As Integer
Dim i As Integer
Dim Cell As Range
 
i = 0
For Each Cell In Line
    If Cell.Value = Name Then
        i = Cell.Column
    End If
Next Cell
 
columnLookup = i
End Function
 
Sub copie()
 
 
    Dim k As Variant
    Dim localworksheet, globalWorksheet As String
    Dim currentLine, currentLine1 As Integer
    Dim classeur As Workbook
 
 
    Dim headerBase As Range
    Dim headerCopie As Range
 
 
    Dim indexNomBase, indexPrenomBase, indexEmailBase As Integer
    Dim indexNomCopie, indexPrenomCopie, indexEmailCopie As Integer
 
 
    globalWorksheet = "base"
    localworksheet = "copie"
 
    Worksheets(globalWorksheet).Activate
 
 
    'Choix du header
 
    Set headerBase = Worksheets(globalWorksheet).Range("A1", Worksheets(globalWorksheet).Range("A1").End(xlToRight))
    Set headerCopie = Worksheets(localworksheet).Range("A1", Worksheets(localworksheet).Range("A1").End(xlToRight))
 
 
    indexNomBase = columnLookup("Nom", headerBase)
    indexPrenomBase = columnLookup("Prénom", headerBase)
    indexEmailBase = columnLookup("Email", headerBase)
 
 
    indexNomCopie = columnLookup("Nom", headerCopie)
    indexPrenomCopie = columnLookup("Prénom", headerCopie)
    indexEmailCopie = columnLookup("Email", headerCopie)
 
 
    'Copier les informations
 
    currentLine1 = 2
 
    For k = 2 To 4
 
 
        Worksheets(localworksheet).Cells(currentLine1, indexNomCopie).Value = Worksheets(globalWorksheet).Cells(k, indexNomBase).Value
        Worksheets(localworksheet).Cells(currentLine1, indexPrenomCopie).Value = Worksheets(globalWorksheet).Cells(k, indexPrenomBase).Value
        Worksheets(localworksheet).Cells(currentLine1, indexEmailCopie).Value = Worksheets(globalWorksheet).Cells(k, indexEmailBase).Value
 
        currentLine1 = currentLine1 + 1
 
    Next k
 
 
End Sub

[EricDgn]

Bonjour,

Cette fonction extrait l'adresse entre < et >:

Code :

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

1
2
3
4
5
6
7
8
9
Public Function AdrMail(s As String) As String
    Dim k As Long
    k = InStr(1, s, "<") + 1
    If k = 1 Then
        AdrMail = ""
    Else
        AdrMail = Mid(s, k, Len(s) - k)
    End If
End Function

à utiliser en ligne 63

Code :

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

 ... = AdrMail(...)

Cordialement.

[anasecu]

Bonjour EricDgn,

Si je peux me permettre en ligne 7 ce serait plus correct :

Code :

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

        AdrMail = Mid(s, k, InStr(1, s, ">") - k)

[jurassic pork]

Hello,
en utilisant les expressions régulières :

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
Function RecupAdrMail(maChaine) As StringDim objReg As Object
Dim objMatches As Object
RecupAdrMail = ""
Set objReg = CreateObject("vbscript.regexp")
objReg.Pattern = "<(.+@.+)>"
Set objMatches = objReg.Execute(maChaine)
If objMatches.Count = 1 Then
    RecupAdrMail = objMatches(0).Submatches.Item(0) 
End If
Set objReg = Nothing
Set objMatches = Nothing
End Function
 
Sub Test()
 Debug.Print RecupAdrMail("Toto Isabelle<t.isabelle@gmail.com>")
End Sub

[EDIT] j'ai corrigé le code (utilisation de groupe) car les <> étaient compris dans la chaîne extraite.

Ami calmant, J.P

[mimich_88]

ça marche à merveille merci énormément <3