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

mimich_88

XLDnaute Nouveau
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
 

Pièces jointes

  • ph3.PNG
    ph3.PNG
    26.6 KB · Affichages: 12
  • ph5.PNG
    ph5.PNG
    25.3 KB · Affichages: 10
  • Email.xlsm
    19.3 KB · Affichages: 2

vgendron

XLDnaute Barbatruc
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

XLDnaute Nouveau
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
 

Discussions similaires

Réponses
9
Affichages
427

Membres actuellement en ligne

Aucun membre en ligne actuellement.

Statistiques des forums

Discussions
300 762
Messages
1 987 022
Membres
209 682
dernier inscrit
tecloveur