Microsoft 365 Utilisation de variables tableau

[DanB34]

Bonsoir,
Pour des raisons de rapidité de traitement et surtout pour savoir comment faire, je voudrais mettre sous forme de variable tableau les adresses mail regroupées via la procédure Sub Rassemble_Mails() afin de coller en une seule opération toute la variable tableau dans la colonne "D" alors qu'actuellement tout se fait ligne par ligne.
J'ai fait plusieurs essais, mais sans trouver la bonne méthode, car je ne sais pas comment créer la boucle qui récupère les données.
Je mets en pj un fichier test.
Merci d'avance pour vos conseils.
Dan

 

[eriiic]

Bonjour,

exemple :

Sub Rassemble_Mails()
    Dim DerLigne As Long
    Const ColRgtMails = "D" 'Regroupement E-Mails
    Dim datas, result() As String, lig As Long, col As Long
    Dim t As Single
    
    t = Timer
    Application.ScreenUpdating = False
    DerLigne = Range("A65000").End(xlUp).Row
    datas = Cells(2, ColRgtMails).Resize(DerLigne - 1, 3).Value ' lecture plage en une fois
    ReDim result(1 To DerLigne - 1, 1 To 1)
    For lig = 1 To UBound(datas)
        For col = 1 To 3
            result(lig, 1) = result(lig, 1) & " " & datas(lig, col)
        Next col
        ' suppression espaces superflus et remplacement par vblf
        result(lig, 1) = Replace(Application.Trim(result(lig, 1)), " ", vbLf)
    Next lig
    Cells(2, ColRgtMails).Resize(UBound(result)) = result
    'Suppression des anciennes colonnes mail
    Columns(ColRgtMails).Offset(, 1).Resize(, 2).Delete shift:=xlToLeft
    Application.ScreenUpdating = True
    MsgBox "temps Rassemble_Mails (s) :" & Timer - t
End Sub

Quand tu écris

Dim NbContact, DerLigne As Integer

il faut toutes les typer. Ici seule DerLigne l'est, NbContact est Variant (par défaut).
De plus pour les lignes il faut As Long. Integer est trop court.
Pour faire simple met toutes tes variables entières As long
eric

 

[laurent950]

Bonsoir,
en essayant de ne pas dénaturer votre logique.

Sub Rassemble_Mails()
Dim TabMail As Variant 'Dim TabMail() As Variant
'Dim TabRgtMail() As Variant
'Dim i As Integer
Dim Ligne As Integer
Dim Colonne As Integer
Dim DerLigne As Integer
'Dim RgtMail As String
Const ColRgtMails = "D" 'Regroupement E-Mails
Const ColMail1 = "E" 'Mail1
Const ColMail2 = "F" 'E-Mail2
Const ColMail3 = "G" 'E-Mail3

Application.ScreenUpdating = False

DerLigne = Range("A65000").End(xlUp).Row
Columns(ColRgtMails & ":" & ColRgtMails).Select
Selection.Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(ColRgtMails & 1) = "E-Mails"

' Redimension automatique du tableau en fonction du nombre de lignes occupées
    'ReDim TabMail(2 To DerLigne, 5 To 7)
    TabMail = Sheets("Contacts").Range(Sheets("Contacts").Cells(2, 5), Sheets("Contacts").Cells(DerLigne, 7))
'  Plus besoin de boucle For.
'    For Ligne = 2 To DerLigne
'        For Colonne = 5 To 7
'            TabMail(Ligne, Colonne) = Sheets("Contacts").Cells(Ligne, Colonne).Value
'            If TabMail(Ligne, Colonne) <> "" Then
'                If RgtMail <> "" Then
'                    RgtMail = RgtMail & vbCrLf & TabMail(Ligne, Colonne)
'                Else
'                    RgtMail = TabMail(Ligne, Colonne)
'                End If
'            End If
'        Next Colonne
'        Range(ColRgtMails & Ligne) = RgtMail
'        RgtMail = Empty
'    Next Ligne
' Resultat obtenu sans boucle dans la colonne D
Sheets("Contacts").Range(ColRgtMails & "2").Resize(UBound(TabMail, 1), 1).Value = Application.Index(TabMail, , 1)

'Suppression des ":" parasites
    Columns(ColRgtMails & ":" & ColRgtMails).Select
    Selection.Replace What:=":", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
      
'Suppression des anciennes colonnes mail
    Columns(ColMail1 & ":" & ColMail3).Delete shift:=xlToLeft

Application.ScreenUpdating = True

End Sub

 

[DanB34]

Bonsoir à vous 2 et merci beaucoup pour l'aide apportée.

- laurent950 : quelque chose ne fonctionne pas, car je n'obtiens pas un regroupement des 3 champs mail dans un seul champ, mais une seule adresse mail. Je n'ai pas trop regardé pour quelle raison ça ne fonctionne pas normalement.

- eriiiic : je suis "sur le cul" tellement ta macro est efficace et rapide. Impressionnant !
Par contre, je ne comprends pas tout et je suis preneur de toutes explications sur ton code :

On passe de datas à result :
datas = Cells(2, ColRgtMails).Resize(DerLigne - 1, 3).Value ' lecture plage en une fois
ReDim result(1 To DerLigne - 1, 1 To 1)

Puis à nouveau à datas
For lig = 1 To UBound(datas)

En tout cas, un grand merci. Le traitement total se déroule en moins de 2 secondes contre environ 12 précédemment.
Merci encore
Dan

 

[eriiic]

Bonjour,

je veux bien t'expliquer un peu plus mais précise les points qui te paraissent obscurs.
N'oublie pas que tu peux faire F1 sur les propriétés/méthodes inconnues pour accéder à l'aide très bien faite.

datas = Cells(2, ColRgtMails).Resize(DerLigne - 1, 3).Value ' lecture plage en une fois

toutes les données se retrouvent dans un tableau de y lignes, x colonnes

ReDim result(1 To DerLigne - 1, 1 To 1)

on prépare le tableau qui recevra les résultats (tableau 2D même si une seule dimension aurait suffit, pour éviter un Transpose() à l'écriture)

For lig = 1 To UBound(datas)

il ne reste plus qu'à balayer toutes les lignes du tableau en mémoire pour concaténer les emails dans le tableau result.
Je n'ai pas laissé le traitement des ":" car je n'en ai pas eu dans ton exemple.
Si c'est à faire, tu peux le faire dans cette boucle. Ou à la fin comme tu faisais, ça ne doit pas être trop consommateur.
eric

 

[laurent950]

Bonsoir,

Sub Rassemble_Mails()
Dim TabMail As Variant
Dim Ligne As Integer
Dim Colonne As Integer
Dim DerLigne As Integer
Const ColRgtMails = "D" 'Regroupement E-Mails
Const ColMail1 = "E" 'Mail1
Const ColMail2 = "F" 'E-Mail2
Const ColMail3 = "G" 'E-Mail3

Application.ScreenUpdating = False

Columns(ColRgtMails & ":" & ColRgtMails).Select
Selection.Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range(ColRgtMails & 1) = "E-Mails"

DerLigne = Range("A65000").End(xlUp).Row
TabMail = Sheets("Contacts").Range(Sheets("Contacts").Cells(2, 5), Sheets("Contacts").Cells(DerLigne, 7))
ReDim Preserve TabMail(LBound(TabMail, 1) To UBound(TabMail, 1), LBound(TabMail, 2) To UBound(TabMail, 2) + 1)

For Ligne = LBound(TabMail, 1) To UBound(TabMail, 1)
    If TabMail(Ligne, 1) <> Empty Then
        TabMail(Ligne, 4) = TabMail(Ligne, 1) & vbCrLf & TabMail(Ligne, 2) & vbCrLf & TabMail(Ligne, 3)
    Else
        TabMail(Ligne, 4) = TabMail(Ligne, 2) & vbCrLf & TabMail(Ligne, 3)
    End If
Next Ligne

Sheets("Contacts").Range(ColRgtMails & "2").Resize(UBound(TabMail, 1), 1).Value = Application.Index(TabMail, , 4)
 
'Suppression des anciennes colonnes mail
    Columns(ColMail1 & ":" & ColMail3).Delete shift:=xlToLeft

Application.ScreenUpdating = True

End Sub

 

[DanB34]

Merci pour les explications eriiiic
et merci à laurent950 pour l'investissement. Je regarderai ce soir et vous tiens informé.
Bien cordialement,
Dan