Microsoft 365 VBA - Extraire tous les emails d'une cellule et les coller dans une autre feuille

mimich_88 · 23 Juin 2022

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)

VB:

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

vgendron · 23 Juin 2022

Bonjour

des images ne servent à rien. on ne peut pas travailler dessus
une piste: utiliser la fonction Split avec le separateur ;
et ensuite, extraire la partie entre < et >

mimich_88 · 23 Juin 2022

vgendron à dit:
Bonjour

des images ne servent à rien. on ne peut pas travailler dessus
une piste: utiliser la fonction Split avec le separateur ;
et ensuite, extraire la partie entre < et >

Bonjour, j'avais oublié le fichier, je viens de l'ajouter

vgendron · 23 Juin 2022

ci dessous le code avec commentaires

VB:

Sub ExtraireMails()
Dim TabSource() As Variant 'déclaration d'un tablo pour récuprer les données à traiter

With Sheets("Source") 'dans la feuille source
    fin = .Range("A" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne A
    TabSource = .Range("A2:B" & fin).Value 'on place les données dans le talbo
End With
With Sheets("Copy") 'dans la feuille Copy
    For i = LBound(TabSource, 1) To UBound(TabSource, 1) 'pour chaque ligne de donnée
        ListMail = Split(TabSource(i, 2), ";") 'on sépare la ligne de mail avec le point virgule==> tous les éléments sont placés dans un tablo "ListMail"
        For j = LBound(ListMail, 1) To UBound(ListMail, 1) 'pour chaque élément de mail
            .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabSource(i, 1) 'on place la donnée "Value"
            .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) = Replace(Split(ListMail(j), "<")(1), ">", "") 'on sépare à nouveau avec le séparateur "<", et on remplace ">" par rien
        Next j
    Next i
End With
End Sub

mimich_88 · 23 Juin 2022

vgendron à dit:

ci dessous le code avec commentaires

VB:

Sub ExtraireMails()
Dim TabSource() As Variant 'déclaration d'un tablo pour récuprer les données à traiter

With Sheets("Source") 'dans la feuille source
    fin = .Range("A" & .Rows.Count).End(xlUp).Row 'dernière ligne non vide de la colonne A
    TabSource = .Range("A2:B" & fin).Value 'on place les données dans le talbo
End With
With Sheets("Copy") 'dans la feuille Copy
    For i = LBound(TabSource, 1) To UBound(TabSource, 1) 'pour chaque ligne de donnée
        ListMail = Split(TabSource(i, 2), ";") 'on sépare la ligne de mail avec le point virgule==> tous les éléments sont placés dans un tablo "ListMail"
        For j = LBound(ListMail, 1) To UBound(ListMail, 1) 'pour chaque élément de mail
            .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = TabSource(i, 1) 'on place la donnée "Value"
            .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) = Replace(Split(ListMail(j), "<")(1), ">", "") 'on sépare à nouveau avec le séparateur "<", et on remplace ">" par rien
        Next j
    Next i
End With
End Sub

parfait merci énormément

Microsoft 365 VBA - Extraire tous les emails d'une cellule et les coller dans une autre feuille

mimich_88

XLDnaute Nouveau

Pièces jointes

vgendron

XLDnaute Barbatruc

mimich_88

XLDnaute Nouveau

vgendron

XLDnaute Barbatruc

mimich_88

XLDnaute Nouveau

Discussions similaires