- Katılım
- 26 Mart 2022
- Mesajlar
- 2
- Excel Vers. ve Dili
- 16
Merhabalar, excel'de belirlenen hücreleri vba makroyla mail olarak gönderme kodunu yazdım. Bu kodda A7 ile N25 sütunları arasındaki satır ve sütunlar gönderiliyor. Buna ek olarak A1 ve N4 arasındaki kodları da eklemek istiyorum yani 2 farklı hücreyi birleştirip o şekilde mail göndermek istiyorum. Alttaki kod hazır ve doğru.
Mail çıktısının bu şekilde olmasını istiyorum.
A1+N4
A7+N25
Bu şekilde taradığım bölgeleri birleştirmek istiyorum.
Kod:
Sub mailsayfa_hucre()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
Set rng = Sheets("sayfa").Range("A7:N25").SpecialCells(xlCellTypeVisible)
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
With OutMail
.to = "hedef@mail.com"
.cc = ""
.bcc = ""
.Subject = "YAKIT FARKI1 sayfa"
.BODY = "Merhaba, Yakıt farkı dosyası ektedir."
.HTMLBody = RangetoHTML(rng)
.send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub
Function RangetoHTML(rng As Range)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
On Error GoTo 0
End With
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close SaveChanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End FunctionMail çıktısının bu şekilde olmasını istiyorum.
A1+N4
A7+N25
Bu şekilde taradığım bölgeleri birleştirmek istiyorum.