- Katılım
- 30 Mart 2008
- Mesajlar
- 84
- Excel Vers. ve Dili
- OFFICE 2016 TR
- Altın Üyelik Bitiş Tarihi
- 21-04-2021
Merhaba Arkadaşlar,
Ekteki dosyadaki Ortalama sayfasında E50:J60 arasındaki notu Mail Yolla butonuna bastğımda çalışan makro ile birleştirmek istiyorum. Ekli dosyada tam olarak anlatmak istediğimi çizerek gösterdim.
Şu andaki makro;
Birleştirmek istediğim
Bu kodların birleştirilmesi konusunda yardımlarınızı rica ediyorum.
Bu kodların birleştirilmesi konusunda bir döküman mevcutsa ve paylaşılırsa çok sevinirim.
Saygılarımla.
Ekteki dosyadaki Ortalama sayfasında E50:J60 arasındaki notu Mail Yolla butonuna bastğımda çalışan makro ile birleştirmek istiyorum. Ekli dosyada tam olarak anlatmak istediğimi çizerek gösterdim.
Şu andaki makro;
Kod:
Sub Send_Row()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range
Dim rng As Range
Dim Ash As Worksheet
Set Ash = ActiveSheet
On Error GoTo cleanup
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
For Each cell In Ash.Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value) = "yolla" Then
Ash.Range("A3:Q150").AutoFilter Field:=2, Criteria1:=cell.Value
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.to = cell.Value
.Subject = "Ready Time Eksik"
.HTMLBody = RangetoHTML(rng)
.Display 'Or use Send
End With
On Error GoTo 0
Set OutMail = Nothing
Ash.AutoFilterMode = False
End If
Next cell
cleanup:
Set OutApp = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End SubBirleştirmek istediğim
Kod:
Sub Mail_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2007
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("MailRangeSelection").Range("E50:J60").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = "ron@debruin.nl"
.CC = ""
.BCC = ""
.Subject = "This is the Subject line"
.HTMLBody = RangetoHTML(rng)
.Display 'or use .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End SubBu kodların birleştirilmesi konusunda bir döküman mevcutsa ve paylaşılırsa çok sevinirim.
Saygılarımla.