Copier range et coller dans mail

Bonjour à toutes un tous

Grace à l'aide de Steelson (merci encore à lui) j'ai désormais la possibilité de récupérer le range voulu.

Ceci étant dit je ne parviens pas à copier coller le même range dans mon mail

Set cel = .Columns("A").Find(maRecherche)
If Not cel Is Nothing Then
    start_active = cel.row
   count_active = cel.MergeArea.Rows.Count
copyrange = start_active + count_active - 1

'Set rng = .Range("A5:I" & copyrange).SpecialCells(xlCellTypeVisible)
'active_copy = .Range("A5:I" & copyrange).Copy

End If

Comment procéder afin de récupérer la range

Range("A5:I" & copyrange)

en la copiant ou la sélectionnant afin de pouvoir l'afficher dans

.HTMLBody

une idée svp?

merci

Bonjour

je reussi à copier les données via

Set RngData = .Range("A5:I" & copyrange)
RngData.Copy

seulement comment les coller via vba

si je fais CTRL V ca colle bien les bonnes données

je tente un RngData.PasteSpecial mais ca me retourne juste vrai...

meme chose avec RngData.PasteSpecial(Paste:=xlPasteValues)

merci par avance pour vos conseils

Bonjour AngeNoir

seulement comment les coller via vba

une solution par ici peut-être ... https://forum.excel-pratique.com/excel/envoyer-un-resume-d-une-partie-d-un-tcd-par-email-sous-forme-...

.htmlbody = tableauhtml(maRange) & .htmlbody

avec

Function tableauhtml(plage As Range) As String
Dim cel As Range
Set cel = plage.Cells(1, 1)
    tableauhtml = "<table>"
    For i = 1 To plage.Rows.Count
        tableauhtml = tableauhtml & "<tr>"
        For j = 1 To plage.Columns.Count
            tableauhtml = tableauhtml & "<td>" & texthtml(cel.Offset(i - 1, j - 1).Value) & "</td>"
        Next
        tableauhtml = tableauhtml & "</tr>"
    Next
    tableauhtml = tableauhtml & "</table>"
End Function

Function texthtml(texte As String)
    texthtml = ""
    For i = 1 To Len(texte)
        Select Case Asc(Mid(texte, i, 1))
        Case Is = 10
            texthtml = texthtml & "<br/>"
        Case Is = 39
            texthtml = texthtml & "&#" & Application.Trim(Str(Asc(Mid(texte, i, 1)))) & ";"
        Case Is > 127
            texthtml = texthtml & "&#" & Application.Trim(Str(Asc(Mid(texte, i, 1)))) & ";"
        Case Else
            texthtml = texthtml & Mid(texte, i, 1)
        End Select
    Next
End Function

merci à vous pour votre retour Steelson et bonjour à vous

j'ai ajouté les deux fonctions et ai tenté d'intégrer le codage mais cela ne fonctionne pas

type d'argument par byref incompatible

 With wb.Sheets("Rapport")
debut = 5
fin = .Range("B" & Rows.Count).End(xlUp).row

maRecherche = "Active"
Set cel = .Columns("A").Find(maRecherche)
If Not cel Is Nothing Then
    start_active = cel.row
   count_active = cel.MergeArea.Rows.Count
copyrange = start_active + count_active - 1

Set RngData = .Range("A5:I" & copyrange)
RngData.Copy
End If

chemin = ThisWorkbook.Path & "\"
Nom = Format(Now(), "dd.mm.yy")
fichier = "Rapport au " & Nom & ".xlsm"

End With

               With Olmail
                   .To = ""
                   .CC = ""
                   .Subject = "Suivi"
                   .Attachments.Add (chemin & fichier)
                   .HTMLBody =  & .HTMLBody
                   .HTMLBody = "Bonjour <br>" & tableauhtml(RngData)
                   
             wb.Close
                   .display

               End With

une idée svp?
merci par avance

Pourquoi mettre ceci ?

                   .HTMLBody =  & .HTMLBody
                   .HTMLBody = "Bonjour <br>" & tableauhtml(RngData)

mets plutôt

                   .HTMLBody = "Bonjour <br>" & tableauhtml(RngData) & .HTMLBody

c'est ce qui m'a sauté au yeux ...

ajoute aussi

dim RngData as range

si ce n'est pas ok, reviens ici ...

merci pour ton retour cela fonctionne mais pas tout à fait

En effet désormais cela me renvoi bien des données dans le mail et même toutes les colonnes mais alors choses étonnantes pas les bonnes lignes

autrement dit le range intiial fixé par Set RngData = .Range("A5:I" & copyrange) et qui fonctionne car si je fais CTRL V cela me colle les bonnes données n'est pas correctement interpreté lors des passages par les 2 fonctions communiqués.

A moins de devoir revoir certains paramètres

a moins d'avoir mal interprété le .HTMLBody

        .HTMLBody = "Bonjour, <br><br>" & _
                   "Voici en condensé :<br><br>" & _
                   "1)  Activité Majeure<br>" & _
                   "2)  Liste des projets actifs (" & count_active & " au total)<br>" & tableauhtml(RngData) & _
                   "3)  Liste des projets soumis et attente d'évaluation par les financeurs (x au total)<br>" & _
                   "4)  Liste des projets en cours de montage (x au total)<br>" & _
                   "5)  Pour un suivi plus global avec projets rejetés ou abandonnés (voir pièce jointe)<br>" & _
                   "Cordialement" & .HTMLBody

merci par avance pour ton aide

Bonne soirée

bonjour

si tu veux une fonction pour convertir en html une plage en voici une de base

en cherchant bien sur DVP on trouve ma ressource

si tu veux les fonction qui vont avec les lignes qui sont bloquées y a qu'a demander

cette fonction gère les cellules fusionnées

pour ceux qui ont encore IE dispo un aperçu de la table s'affiche

Sub test()
    Dim plage As Range
    Set plage = Range("A1:F5")
    x = htmltable(plage)

    Set IE = CreateObject("internetexplorer.application")
    IE.Visible = True
    IE.navigate "about:blank"
    IE.document.write x

End Sub
Function htmltable(plage As Object)
    Dim TBODY, TR, TD, Bord
    Set doc = CreateObject("htmlfile")
    doc.body.innerhtml = "<table><tbody></table></tbody>"
    Set Table = doc.getelementsbytagname("TABLE")(0)
    With Table.Style
    .Bordercollapse = "collapse": .FontSize = "11pt": .fontfamily = "calibri"
    End With
    Set TBODY = doc.getelementsbytagname("TBODY")(0)
    For lig = 1 To plage.Row + plage.Rows.Count - 1
        Set TR = doc.createelement("TR")
        TBODY.appendchild (TR)
        For col = 1 To plage.Column + plage.Columns.Count - 1
            Set cel = plage.Cells(lig, col)
            If doc.getelementbyid(cel.MergeArea.Address) Is Nothing Then
                Set TD = doc.createelement("TD")
                TD.ID = cel.MergeArea.Address
                TD.rowspan = cel.MergeArea.Rows.Count: TD.colspan = cel.MergeArea.Columns.Count
                Bord = bordureTD(cel.MergeArea)
                TD.Style.Width = Round(cel.MergeArea.Width) & "pt"
                TD.Style.Height = Round(cel.MergeArea.Height) & "pt"
                TD.innerhtml = "<Font>" & cel.text & "</font>"
                TD.Style.Border = "1px solid  black"
                'TD.Style.borderstyle = Bord(0)
                'TD.Style.borderwidth = Bord(1)
                'TD.Style.bordercolor = Bord(2)
                TR.appendchild (TD)
            End If
        Next
    Next
    htmltable = table.outerhtml
End Function

bonne soirée

Bonjour,

Set RngData = .Range("A5:I" & copyrange) et qui fonctionne car si je fais CTRL V cela me colle les bonnes données n'est pas correctement interpreté lors des passages par les 2 fonctions communiqués.

a moins d'avoir mal interprété le .HTMLBody

ce qui effectivement est incompréhensible ! As-tu une copie d'écran ?

N'ayant pas ton fichier, fais juste un test comme suit :

sub test()
dim RngData as range
set RngData = Range("A5:I" & copyrange)
debug.print tableauhtml(RngData)
end sub

et affiche la fenêtre d'exécution dans l'éditeur de macro (Ctrl+G)

Renvoie la réponse (ou envoie ton fichier en mp).

Bonjour Steelson

voici le fichier retraçant le soucis.

Il faut lancer la macro dans le fichier test

tu pourras constater qu'après la macro lancée ce qui est généré dans le mail ou le debug ne correspond pas au ctrl v qui lui est correct

4test.zip (28.96 Ko)

merci par avance,

bonne journée

bonjour

c'est a ce demander si je suis invisible

donc je reprend une dernière fois

tu copie pas la plage tu colle pas la plage !!!

met toi un nouveau module

colle lui ca et adapte ta plage dans la ligne "Tabl=....."

Option Explicit
Sub envoie()
    Dim Tabl, olApp As Object, olMail As Object, olMailItem, message$
    '***********************************
    'récupération du tableau en code html
    Tabl = htmltable(Feuil1.[A1:F5])
    '***********************************
    Set olApp = CreateObject("outlook.application")
    Set olMail = olApp.CreateItem(olMailItem)

    With olMail
        .Subject = "Suivi de Stock quotidien"
        .To = "adresse@mail.com"
        '.CC = Range("L" & Ligne) 'ou .BCC pour Cci
        message = "Chers collègues, <br/><br/> Veuillez trouver ci-dessous l'état des stocks du jour, le " _
                & Date & ". <br/><br/>" & Tabl & "<br/><br/> Bonne fin de journée !"

        .htmlbody = message
        .Display
    End With

End Sub

ensuite la fonction qui va encoder le code html de ta plage

Function htmltable(plage As Object)
    Dim Doc As Object, TBODY, Table, TR, TD, Bord, Lig&, col&, cel As Range, Ta, Tal, Va, Vral
    Set Doc = CreateObject("htmlfile")
    Doc.body.innerhtml = "<table><tbody></table></tbody>"
    Set Table = Doc.getelementsbytagname("TABLE")(0)
    With Table.Style
        .Bordercollapse = "collapse": .FontSize = "11pt": .fontfamily = "calibri"
    End With
    Set TBODY = Doc.getelementsbytagname("TBODY")(0)
    For Lig = 1 To plage.Row + plage.Rows.Count - 1
        Set TR = Doc.createelement("TR")
        TBODY.appendchild (TR)
        For col = 1 To plage.Column + plage.Columns.Count - 1
            Set cel = plage.Cells(Lig, col)
            If Doc.getelementbyid(cel.MergeArea.Address) Is Nothing Then
                Set TD = Doc.createelement("TD")
                TD.ID = cel.MergeArea.Address
                TD.rowspan = cel.MergeArea.Rows.Count: TD.colspan = cel.MergeArea.Columns.Count
                TD.Style.Width = Round(cel.MergeArea.Width) & "pt"
                TD.Style.Height = Round(cel.MergeArea.Height) & "pt"
                TD.innerhtml = "<Font>" & cel.Value & "</font>"
                TD.Style.Border = "1px solid  black"
                If cel(1).WrapText = True Then TD.Style.wordBreak = "break-all"                                  'applique le wraptext de la  cellule
                TD.Style.margin = "1pt"                                                                          'applique la marge de excel
                '******************************************************************************************************************************
                'option Bloquer ces lignes ci dessous  et vous avez votre tableau en noir et blanc(commentaire
                'If Not IsNull(cel.Font.Color) Or cel.Font.Color <> vbBlack Then TD.Style.Color = coul_XL_to_coul_HTMLX(cel.Cells(1).Font.Color)
                'If Not IsNull(cel.Font.Name) Then TD.Style.fontfamily = cel.Font.Name                           'applique le font name de la cellule
                'TD.Style.backgroundcolor = coul_XL_to_coul_HTMLX(cel.Interior.Color)                            'applique la couleur de fond de la cellule

                'Bord = bordureTD(cel.MergeArea)                                                                 'appel fonction recupe le style de bordure en html
                'TD.Style.borderstyle = Bord(0)                                                                  'applique le border style
                'TD.Style.borderwidth = Bord(1)                                                                  'applique le borderweight
                'TD.Style.BorderColor = Bord(2)                                                                  'applique le bordercolor

                'alignement(commentaire)
                'Ta = cel.HorizontalAlignment: Tal = Switch(Ta = xlLeft, "left", Ta = xlCenter, "center", Ta = xlRight, "right", Ta = xlGeneral, "left", IsDate(cel.Value) And Ta = xlGeneral, "right")
                'Va = cel.VerticalAlignment: Vral = Switch(Va = xlTop, "top", Va = xlCenter, "middle", Va = xlBottom, "bottom", Va = xlGeneral, "bottom")
                'If IsDate(cel.Value) And Ta = xlGeneral Then Tal = "right"
                'TD.Style.TextAlign = Tal
                'TD.Style.verticalalign = Vral

                '******************************************************************************************************************************
                TR.appendchild (TD)
            End If
        Next
    Next
    htmltable = Table.outerhtml
End Function

comme tu peux le voir j'ai bloqué des ligne qui me servent a appliquer le style (on a donc ta plage en html en noir et blanc)

démonstration

demo7

si tu veux la couleur débloque les lignes bloquées entre les deux lignes d'asterisque et ajoute ceci dans le module

'option
'les bordures
'la couleur en format html
Function bordureTD(cel)
'top right bottom left
    Dim Tabl(3), BDTW, BDRW, BDBW, BDLW, BDTC, BDRC, BDBC, BDLC, bordurestyle, bordureweight, BorderColor
    With cel
        BDTW = IIf(.Borders(xlEdgeTop).LineStyle = xlNone, "1", .Borders(xlEdgeTop).Weight)
        BDRW = IIf(.Borders(xlEdgeRight).LineStyle = xlNone, "1", .Borders(xlEdgeRight).Weight)
        BDBW = IIf(.Borders(xlEdgeBottom).LineStyle = xlNone, "1", .Borders(xlEdgeBottom).Weight)
        BDLW = IIf(.Borders(xlEdgeLeft).LineStyle = xlNone, "1", .Borders(xlEdgeLeft).Weight)

        BDTC = IIf(.Borders(xlEdgeTop).LineStyle = xlNone, "#E6E6E6", coul_XL_to_coul_HTMLX(.Borders(xlEdgeTop).Color))
        BDRC = IIf(.Borders(xlEdgeRight).LineStyle = xlNone, "#E6E6E6", coul_XL_to_coul_HTMLX(.Borders(xlEdgeRight).Color))
        BDBC = IIf(.Borders(xlEdgeBottom).LineStyle = xlNone, "#E6E6E6", coul_XL_to_coul_HTMLX(.Borders(xlEdgeBottom).Color))
        BDLC = IIf(.Borders(xlEdgeLeft).LineStyle = xlNone, "#E6E6E6", coul_XL_to_coul_HTMLX(.Borders(xlEdgeLeft).Color))

        bordurestyle = .Borders(xlEdgeTop).LineStyle & " " & .Borders(xlEdgeRight).LineStyle & " " & .Borders(xlEdgeBottom).LineStyle & " " & .Borders(xlEdgeLeft).LineStyle
        bordurestyle = Replace(Replace(Replace(Replace(Replace(Replace(bordurestyle, -4118, "dotted"), "-4119", "double"), "-4115", "dashed"), "-4142", "solid"), "1", "solid"), "4", "dashed")

        bordureweight = BDTW & " " & BDRW & " " & BDBW & " " & BDLW
        BorderColor = BDTC & " " & BDRC & " " & BDBC & " " & BDLC
        bordureweight = Replace(Replace(Replace(Replace(Replace(bordureweight, "-4138", "2px "), 4, "3px "), 1, "1px "), 2, "2px "), " px", "")
    End With
    Tabl(0) = bordurestyle
    Tabl(1) = bordureweight
    Tabl(2) = BorderColor
    bordureTD = Tabl
End Function

Function coul_XL_to_coul_HTMLX(couleur)
    Dim str0 As String, strf As String
    str0 = Right("000000" & Hex(couleur), 6): strf = Right(str0, 2) & Mid(str0, 3, 2) & Left(str0, 2)
    coul_XL_to_coul_HTMLX = "#" & strf & ""
End Function

voila maintenant avec les ligne débloquées et les deux fonction supplementaires

démonstration

demo7

voila

enjoy:)

En effet, c'est (de nouveau) lié aux plages fusionnées, une vraie calamité !

Je vais regarder ...

Ajoute

RngData.Cells.UnMerge

dans le code juste ici :

Set RngData = .Range("A5:I" & copyrange)
RngData.Cells.UnMerge

Bonjour Patricktoulon,

désolé je n'avais pas vu votre post précédent. Je vais tenter votre module merci de l'avoir partagé.

@Steelson: je n'ai pas la main sur le fichier rapport il est généré depuis une autre macro donc ne peut le modifier

re

et pourquoi dé fusionner je viens de vous montrer comment on fait

ma fonction gère parfaitement bien les fusions

si vous preniez la peine d'essayer pour voir

une recherche avec mon pseudo sur Develloppez.com t'aurait grandement aidé

et si tu veux le texte de différente couleur dans une cellule html y a qu'a demander

@Steelson: je n'ai pas la main sur le fichier rapport il est généré depuis une autre macro donc ne peut le modifier

tu peux le modifier temporairement ? et le fermer sans le modifier ...

si vous preniez la peine d'essayer pour voir

D'abord Bonjour Patrick,

j'ai essayé, en effet (je vais souvent au plus simple et j'ai en horreur les cellules fusionnées pour lesquelles je préfère une MFC)

après je suis aussi adepte du très léger (1.500 caractères versus 28.000 caractères)

edit : tu peux aussi prendre les sujets depuis le début, regarde dans il y en a plein, https://forum.excel-pratique.com/liste/sujets-sans-reponse y compris sur google sheets

@Patrick: merci, en effet cela fonctionne super bien je récupère bien les lignes concernées et cela s'affiche correctement dans le mail!

Grand merci

Bonjour Steelson

je sais pas de quoi tu parle (1500 caractères........)

si tu parle en terme de code si tu enlève la creation du style CSS mon moteur de creation de creation dans la routine fait de moins de 10 lignes (avec les fusions )

le model simple en noir est blanc sans style

Function htmltable(plage As Object)
    Dim Doc As Object, TBODY, Table, TR, TD, Bord, Lig&, col&, cel As Range, Ta, Tal, Va, Vral
    Set Doc = CreateObject("htmlfile")
    Doc.body.innerhtml = "<table><tbody></table></tbody>"
    Set Table = Doc.getelementsbytagname("TABLE")(0)
    With Table.Style: .Bordercollapse = "collapse": .FontSize = "11pt": .fontfamily = "calibri": End With
    Set TBODY = Doc.getelementsbytagname("TBODY")(0)
    For Lig = 1 To plage.Row + plage.Rows.Count - 1
        Set TR = Doc.createelement("TR"):TBODY.appendchild (TR)
        For col = 1 To plage.Column + plage.Columns.Count - 1
            Set cel = plage.Cells(Lig, col)
            If Doc.getelementbyid(cel.MergeArea.Address) Is Nothing Then
                Set TD = Doc.createelement("TD"): TD.ID = cel.MergeArea.Address
                TD.rowspan = cel.MergeArea.Rows.Count: TD.colspan = cel.MergeArea.Columns.Count
                TD.innerhtml = "<Font>" & cel.Value & "</font>"
                With TD.Style
                    .Width = Round(cel.MergeArea.Width) & "pt": .Height = Round(cel.MergeArea.Height) & "pt"
                    .Border = "1px solid  black": .margin = "1pt"
                    If cel(1).WrapText = True Then TD.Style.wordBreak = "break-all"  'applique le wraptext de la  cellule
                End With
                 TR.appendchild (TD)
            End If
        Next
    Next
    htmltable = Table.outerhtml
End Function

c'est assez simple en fait

je laisse juste le style minimum pour garder le wraptext et les largeurs et le margin

@darkangel

cette fonction évite en effet de devoir défusionner ...

Function tableauhtml(plage As Range) As String
Dim tbl
tbl = plage.Value
Dim i%, j%
    tableauhtml = "<table>"
    For i = 1 To UBound(tbl)
        tableauhtml = tableauhtml & "<tr>"
        For j = 1 To UBound(tbl, 2)
            tableauhtml = tableauhtml & "<td>" & texthtml(tbl(i, j)) & "</td>"
        Next
        tableauhtml = tableauhtml & "</tr>"
    Next
    tableauhtml = tableauhtml & "</table>"
End Function

Function texthtml(texte As Variant)
    texthtml = ""
    For i = 1 To Len(texte)
        Select Case Asc(Mid(texte, i, 1))
        Case Is = 10
            texthtml = texthtml & "<br/>"
        Case Is = 39
            texthtml = texthtml & "&#" & Application.Trim(Str(Asc(Mid(texte, i, 1)))) & ";"
        Case Is > 127
            texthtml = texthtml & "&#" & Application.Trim(Str(Asc(Mid(texte, i, 1)))) & ";"
        Case Else
            texthtml = texthtml & Mid(texte, i, 1)
        End Select
    Next
End Function

maintenant continue avec Patrick si tu le souhaites

edit : j'ai remis la gestion des caractères diacritiques

re

non c'est faux Steelson ca ne gere pas les fusions regarde le code html que j'obtient avec ton code

<table><tr><td>vvvd</td><td></td><td></td><td></td><td></td><td></td></tr><tr><td></td><td>zzzdz</td><td>zzdfz</td><td>dfdf</td><td></td><td>dfdf</td></tr><tr><td></td><td>ddd</td><td></td><td>dfdfd</td><td></td><td></td></tr><tr><td></td><td></td><td>aaaaaaaaaaaaaaaaaaaaaaa</td><td></td><td></td><td>sdfdf</td></tr><tr><td>dd</td><td>dd</td><td>hgfgf</td><td></td><td></td><td>dfdfcd</td></tr></table>
vvvd
zzzdzzzdfzdfdfdfdf
ddddfdfd
aaaaaaaaaaaaaaaaaaaaaaasdfdf
ddddhgfgfdfdfcd

celle a droite de "aaaaaaa..." ne devrait pas exister avec l'exemple de la plage dans mon fichier

tu pense qu'elle n'y est pas par ce que dans le mail il n'y a pas les bordure

la seule solution c'est soit le dictionnaire mergearea.address soit le test d'existence dans la construction en DOM avec le id qui est dans mon code l'address de la cellule

edit : tu peux aussi prendre les sujets depuis le début, regarde dans il y en a plein, https://forum.excel-pratique.com/liste/sujets-sans-reponse y compris sur google sheets

heu... je crains de comprendre ou me trompais-je ?

Rechercher des sujets similaires à "copier range coller mail"