Echec envoi par mail aprés filtre..!?

Bonjour à tous,

Je bataille depuis plusieurs heures pour adapter un script VBA à mon usage personnel. ( Au passage, merci à son auteur.. )

Ce code me permets d'envoyer une sélection d'enregistrements en fonction de leurs propres destinataires.

J'ai bien avancé et jusque là tout semble fonctionner, oui, mais... Il y a toujours un "mais" pour ceux qui ne sont pas doués

Ce code qui est construit autour de 2 feuilles me remonte une erreur lorsqu'il boucle sur la seconde, normal, me direz-vous, puisque je ne travaille que sur une feuille

Quelle modification dois-je apporter pour ne travailler que sur la feuille active ?

Aussi, si je filtre à la main le champs "semaines" avant de lancer la macro, le script remonte une erreur.

Comment contourner cette erreur et n'envoyer que la sélection après filtre ?

Je vous joins le fichier pour exemple.

Merci de votre aide

12fichier-test.xlsm (42.60 Ko)

Bonjour,

à tester,

Sub envoi_recapHS()

    Dim recapHS As New Dictionary                  'dictionnaire des lignes du rapport
    Dim fso As New Scripting.FileSystemObject       'objet de gestion des fichiers
    Dim ligne As Range, ligne_à_envoyer As Range, lignes As Range
    Dim destinataire As Variant
    Dim flux_texte As Object, fichier As Object
    Dim erreur As Boolean, traitement_ok As Boolean

    traitement_ok = True                    'initialisation indicateur de traitement

'    For Each Feuille In ThisWorkbook.Worksheets

'        Feuille.Name = "Données"
            '.... stockage des lignes du rapport dans un dictionnaire ayant pour clé l'adresse mail du destinataire
            With ActiveSheet
              'masquage des colonnes à ne pas faire figurer dans le rapport
              .Columns("A").Hidden = True           'masquage colonne A
              .Columns("J:K").Hidden = True         'masquage colonnes J à K
              .Columns("M:O").Hidden = True         'masquage colonnes M à O
              .Columns("Q:R").Hidden = True           'masquage colonnes Q à R

              'sélection et stockage des lignes du rapport dans le dictionnaire
              For Each ligne In .UsedRange.Rows     'lignes utilisées
                    destinataire = ligne.Columns("K").Value
                    Set ligne_à_envoyer = ligne.SpecialCells(xlCellTypeVisible)
                    If destinataire <> Empty Then
                        If Not recapHS.Exists(destinataire) Then recapHS.Add Key:=destinataire, Item:=ligne_à_envoyer _
                        Else Set recapHS(destinataire) = Union(recapHS(destinataire), ligne_à_envoyer)
                    End If
              Next ligne

              'réaffichage des colonnes ne figurant pas dans le rapport
              .Columns("A").Hidden = False           'masquage colonne A
              .Columns("J:K").Hidden = False       'masquage colonnes J à K
              .Columns("M:O").Hidden = False        'masquage colonnes M à O
              .Columns("Q:R").Hidden = False          'masquage colonnes Q à R
            End With

            '..... création classeur temporaire avec copie feuille en cours
            With ActiveSheet
                .Copy
            End With
            ActiveSheet.Range("A:A").Delete    'suppression colonnes non affichées dans le rapport

            '.... récupération des lignes du rapport à partir du dictionnaire et stockage dans une page Web
            For Each destinataire In recapHS.Keys
                If destinataire = "Usermail" Then
                    Set ligne_entête = recapHS(destinataire)
                Else
                    'création rapport dans le classeur temporaire
                    Set lignes = Union(ligne_entête, recapHS(destinataire))
                    With ActiveSheet
                        .Cells.Clear                'initialisation feuille
                        lignes.Copy .Range("A1")    'copie lignes du rapport
                    End With

                    'création rapport au format html
                    nom_fichier = "C:\temp\recapHS.htm"
                    With ActiveWorkbook.PublishObjects.Add(SourceType:=xlSourceSheet, Filename:=nom_fichier, Sheet:=ActiveSheet.Name)
                        .Publish (True)
                        .AutoRepublish = False
                    End With

                    'récupération en texte du rapport au format html
                    Set flux_texte = fso.OpenTextFile(nom_fichier)
                    html_texte = flux_texte.ReadAll
                    flux_texte.Close                            'fermeture fichier temporaire
                    Set fichier = fso.GetFile(nom_fichier)
                    fichier.Delete                              'suppression fichier temporaire

                    'envoi mail
                    Call envoi_mail(destinataire, html_texte, erreur)
                    If erreur Then traitement_ok = False
                End If
            Next destinataire

            '..... fermeture classeur temporaire et réinitialisation dictionnaire
            ActiveWorkbook.Close SaveChanges:=False     'fermeture classeur temporaire
            recapHS.RemoveAll                          'réinitialisation dictionnaire

    '..... message fin traitement
    If traitement_ok Then MsgBox "Récapitulatif heures sup envoyé aux destinataires"
'Next Feuille
End Sub

Bonsoir SabV,

Merci beaucoup de t'être penché sur mon problème.

Une partie du problème est résolu , en revanche il existe toujours une erreur "1004 Pas de cellule correspondantes" lorsque je filtre la colonne "Semaine" avant de lancer la macro..

 Set ligne_à_envoyer = ligne.SpecialCells(xlCellTypeVisible)

Et là, je sèche toujours ..

re,

si tu transforme les données de l'onglet "Données" en tableau

tu pourrais modifier la ligne

For Each ligne In .UsedRange.Rows     'lignes utilisées

par

For Each ligne In .ListObjects("Tableau1").DataBodyRange.SpecialCells(xlCellTypeVisible)      'lignes utilisées

fait un essai sur l'onglet "Données1"

Rechercher des sujets similaires à "echec envoi mail filtre"