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
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
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
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 zzzdz zzdfz dfdf dfdf ddd dfdfd aaaaaaaaaaaaaaaaaaaaaaa sdfdf dd dd hgfgf dfdfcd
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