Discussion :

[mimich_88]

Bonjour,

J'ai un programme qui extrait l'email entre guillemets et le copie dans une autre feuille, par contre il extrait que le premier email et j'ai des cellules qui contiennent plus que 3 emails donc je dois extraire tous les emails et les copier dans une autre feuille en respectant une seule condition l'email doit être affiché devant sa valeur associée ( c'est plus simple à comprendre avec les photos : Je copie les données que j'ai dans l'onglet Source dans l'onglet Copy, mais pour l'instant il copie que le premier email, je veux avoir le meme résultat que j'ai dans l'onglet Target)

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
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
Public Function AdrMail(s As String) As String
 
    Dim A As Long
 
    A = InStr(1, s, "<") + 1
 
    If A = 1 Then
 
        AdrMail = ""
 
    Else
 
        AdrMail = Mid(s, A, InStr(1, s, ">") - A)
 
    End If
 
End Function
Sub CopyfromSource()
 
 
    Dim k As Variant
    Dim localworksheet, globalWorksheet As String
    Dim currentLine, currentLine1 As Integer
    Dim classeur As Workbook
 
    Dim headerSource As Range
    Dim headerCopy As Range
 
    Dim valueSource, emailSource, valueCopy, emailCopy As Integer
 
 
    globalWorksheet = "Source"
    localworksheet = "Copy"
 
 
    Worksheets(globalWorksheet).Activate
 
    Set headerSource = Worksheets(globalWorksheet).Range("A1", Worksheets(globalWorksheet).Range("A1").End(xlToRight))
    Set headerCopy = Worksheets(localworksheet).Range("A1", Worksheets(localworksheet).Range("A1").End(xlToRight))
 
 
    valueSource = columnLookup("Value", headerSource)
    emailSource = columnLookup("Email", headerSource)
    valueCopy = columnLookup("Value", headerCopy)
    emailCopy = columnLookup("Email", headerCopy)
 
 
    'Copy
 
    currentLine1 = 2
 
    For k = 2 To 10
 
 
        Worksheets(localworksheet).Cells(currentLine1, valueCopy).Value = Worksheets(globalWorksheet).Cells(k, valueSource).Value
        Worksheets(localworksheet).Cells(currentLine1, emailCopy).Value = AdrMail(Worksheets(globalWorksheet).Cells(k, emailSource).Value)
 
        currentLine1 = currentLine1 + 1
 
    Next k
 
 
    Worksheets(localworksheet).Activate
 
 
End Sub

[BENNASR]

Bonjour
je crois que pour ce genre de traitement la meilleure solution c'est powerquery
Étapes :
- insérer tableau structuré et démarrer l'éditeur powerquery
- Remplacer "<" par "|"
- Remplacer ">" par "|"
-fractionner la colonne par délimiteur "|"
- Clique droite sur la colonne A et dépivoter les autres colonnes
- Faire un filtre avec les lignes ou il y a "@"
- fermer et charger

ça donne :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
let
    Source = Excel.CurrentWorkbook(){[Name="Tableau4"]}[Content],
    #"Type modifié" = Table.TransformColumnTypes(Source,{{"Value", type text}, {"Email", type text}}),
    #"Valeur remplacée" = Table.ReplaceValue(#"Type modifié","<","|",Replacer.ReplaceText,{"Email"}),
    #"Valeur remplacée1" = Table.ReplaceValue(#"Valeur remplacée",">","|",Replacer.ReplaceText,{"Email"}),
    #"Fractionner la colonne par délimiteur" = Table.SplitColumn(#"Valeur remplacée1", "Email", Splitter.SplitTextByDelimiter("|", QuoteStyle.Csv), {"Email.1", "Email.2", "Email.3", "Email.4", "Email.5", "Email.6", "Email.7"}),
    #"Type modifié1" = Table.TransformColumnTypes(#"Fractionner la colonne par délimiteur",{{"Email.1", type text}, {"Email.2", type text}, {"Email.3", type text}, {"Email.4", type text}, {"Email.5", type text}, {"Email.6", type text}, {"Email.7", type text}}),
    #"Supprimer le tableau croisé dynamique des autres colonnes" = Table.UnpivotOtherColumns(#"Type modifié1", {"Value"}, "Attribut", "Valeur"),
    #"Lignes filtrées" = Table.SelectRows(#"Supprimer le tableau croisé dynamique des autres colonnes", each Text.Contains([Valeur], "@")),
    #"Colonnes supprimées" = Table.RemoveColumns(#"Lignes filtrées",{"Attribut"})
in
    #"Colonnes supprimées"

[jurassic pork]

Hello,
voici une solution similaire en power query ( brut , non retouché ou optimisé)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
let
    Source = Excel.Workbook(File.Contents("D:\Logiciels\Excel\testEmail.xlsm"), null, true),
    Tableau1_Table = Source{[Item="Tableau1",Kind="Table"]}[Data],
    #"Type modifié" = Table.TransformColumnTypes(Tableau1_Table,{{"Value", type text}, {"Email", type text}}),
    #"Fractionner la colonne par délimiteur" = Table.ExpandListColumn(Table.TransformColumns(#"Type modifié", {{"Email", Splitter.SplitTextByDelimiter(";", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Email"),
    #"Type modifié1" = Table.TransformColumnTypes(#"Fractionner la colonne par délimiteur",{{"Email", type text}}),
    #"Fractionner la colonne par délimiteur1" = Table.SplitColumn(#"Type modifié1", "Email", Splitter.SplitTextByDelimiter("<", QuoteStyle.Csv), {"Email.1", "Email.2"}),
    #"Type modifié2" = Table.TransformColumnTypes(#"Fractionner la colonne par délimiteur1",{{"Email.1", type text}, {"Email.2", type text}}),
    #"Colonnes supprimées" = Table.RemoveColumns(#"Type modifié2",{"Email.1"}),
    #"Colonnes renommées" = Table.RenameColumns(#"Colonnes supprimées",{{"Email.2", "Email"}}),
    #"Valeur remplacée" = Table.ReplaceValue(#"Colonnes renommées",">","",Replacer.ReplaceText,{"Email"})
in
    #"Valeur remplacée"

Ami calmant, J.P

[mimich_88]

Merci pour votre aide, mais malheureusement il faut que je le fasse en VBA car le programme entier est déja fait en VBA, il me reste que cette partie

[jurassic pork]

Voici une solution en VBA :
1 - Le tableau source est un tableau structuré (Tableau1)
2 - Le tableau destination est un tableau structuré sans données (Tableau2 ) avec comme entêtes de colonne Valeur , Email.

On utilise une fonction qui extrait les adresses email et renvoie un ArrayList de ces adresses. On utilise les expressions régulières pour extraire les emails.

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
Sub CopieEmails()
    Dim ArrEmail As Object
    Dim Email
    Dim newrow As ListRow, row As ListRow
    Dim lstSrc As ListObject, lstDest As ListObject, sht As Worksheet
    Set lstSrc = Sheets("Feuil1").ListObjects("Tableau1")
    Set lstDest = Sheets("Feuil1").ListObjects("Tableau2")
    If Not lstDest.DataBodyRange Is Nothing Then
            lstDest.DataBodyRange.Delete
        End If
    For Each row In lstSrc.ListRows
       Set ArrEmail = RecupAdrMail(row.Range.Cells(2))
       For Each Email In ArrEmail
          Set newrow = lstDest.ListRows.Add
          newrow.Range.Cells(1) = row.Range.Cells(1)
          newrow.Range.Cells(2) = Email
       Next Email
       Set ArrEmail = Nothing
    Next row
    Set lstSrc = Nothing
    Set lstDest = Nothing
End Sub
 
Function RecupAdrMail(maChaine As String) As Object
Dim objReg As Object
Dim objMatches As Object
Dim Match
Set RecupAdrMail = CreateObject("System.Collections.ArrayList")
Set objReg = CreateObject("vbscript.regexp")
objReg.Pattern = "<(.+?@.+?)>"
objReg.Global = True
Set objMatches = objReg.Execute(maChaine)
If objMatches.Count > 0 Then
    For Each Match In objMatches
       RecupAdrMail.Add Match.Submatches(0)
    Next
End If
Set objReg = Nothing
Set objMatches = Nothing
End Function

Ami calmant, J.P

[mimich_88]

Je te remercie pour ton aide, J'ai exécuté ton code mais j'ai une erreur ( subscript out of range )

[jurassic pork]

Hello,
c'est un peu normal que tu ais ce genre d'erreur dans ton classeur si tu utilises mon code dans ton classeur sans faire de modification.

1 - Dans les instructions :

Code :

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

1
2
    Set lstSrc = Sheets("Feuil1").ListObjects("Tableau1")
    Set lstDest = Sheets("Feuil1").ListObjects("Tableau2")

Il faut que tu remplaces le nom de feuille (Feuil1) par le nom de l'onglet où se trouve le tableau concerné.
1 - Il faut que les tableaux structurés Tableau1 , Tableau2 existent dans ton classeur.


Pour Transformer une plage de cellules en tableau structuré :
Sélectionner la plage (avec les entêtes) et faire menu Insertion/Tableau. Dans la fenêtre d'insertion créer un tableau qui s'ouvre, cocher Mon tableau comporte des en-têtes. Cliquer sur OK. Dans Nom du Tableau du ruban, renommer le Tableau avec le nom voulu.


Il y a un truc louche dans ta capture d'écran du message d'erreur VBA --> Le message est en anglais.


Ami calmant, J.P

[mimich_88]

Salut,
enfait j'ai changé le nom de ma feuille selon le code c'est pas je l'ai pas changé, mais je n'avais pas donné un nom aux tableaux c'est pour celà ça n'avait pas marché, mais là ça marche bien, merci beaucoup
Le seul problème c'est qu'il donne le résultat dans la même feuille et mon besoin c'est de copier le résultat dans une autre feuille
Merci beaucoup pour ton aide

[jurassic pork]

Hello,

Le seul problème c'est qu'il donne le résultat dans la même feuille et mon besoin c'est de copier le résultat dans une autre feuille

il suffit que tu mettes le tableau de destination (Tableau2) dans une autre feuille et que tu l'indiques dans le code. Exemple :

Code :

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

1
2
 
  Set lstDest = Sheets("Feuil2").ListObjects("Tableau2")

Ami calmant, J.P

[mimich_88]

ça fonctionne merci beaucoup