• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excel de Formülleri değere çevir e-mail gönder

A

Ahmet ÖZGÜR

Altın Üye
Katılım
8 Haziran 2010
Mesajlar
349
Excel Vers. ve Dili
Office 2003 TR Office 2007 Office 2010
Merhaba,

Şuradaki konudan elde ettiğim kodları uyguladım fakat e-mail gönderdiğimde mail açılınca sayılar "değer" olarak çıkıyor formüllü olduğu için bu kod da değere veya sayıya çevir deyip ondan sonra makro mail gönderse olur mu?

Kod: 
Sub SendShByEmail()
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String
Dim i As Integer
Dim ModX As Object, VBComp As Object
 
ShName = ActiveSheet.Name
WbName = "C:\" & ShName & ".xls"
 
ThisWorkbook.SaveCopyAs WbName
 
Application.DisplayAlerts = False
Workbooks.Open WbName
For i = Sheets.Count To 1 Step -1
If ActiveWorkbook.Sheets(i).Name <> ShName Then Sheets(i).Delete
Next
 
On Error Resume Next
For Each ModX In ActiveWorkbook.VBProject.VBComponents
Set VBComp = ActiveWorkbook.VBProject.VBComponents(ModX.Name)
ActiveWorkbook.VBProject.VBComponents.Remove VBComp
Next
On Error GoTo 0
Application.DisplayAlerts = True
 
ActiveWorkbook.Close SaveChanges:=True
 
Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)
With NewMail
.To = "isim@firma.com"
.To = "isimburaya@firma.com"
.Subject = "Sipairiş Genel Durum"
.Body = "Sipairiş Genel Durum Ektedir. İyi Günler."
.Attachments.Add WbName
.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
Set VBComp = Nothing
Kill WbName
End Sub
 
Ve birden fazla mail adresi nasıl girerim
 
1 nolu mesajdaki sorunuz için

On Error GoTo 0

yukarıdaki prosedür den sonra aşağıdaki bölümü ekleyiniz.

Kod: 
Cells.Copy
Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
 
halit3' Alıntı:
1 nolu mesajdaki sorunuz için

On Error GoTo 0

yukarıdaki prosedür den sonra aşağıdaki bölümü ekleyiniz.

Kod: 
Cells.Copy
Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Genişletmek için tıkla ...
Merhaba Halit Bey

Teşekkür ederim fakat kodu eklememe ragmen #başv olarak maile ekliyor .
 

Ekli dosyalar

  • başv.png
    başv.png
    46.6 KB · Görüntüleme: 7
Formüller başka dosyadaki bilgilere başvuruyormu ?
ne demek lazım bilmiyorum örnek dosya ekleyiniz.
 
Evet Başvuruyor dosya da farklı sayfalar var ve biraz kalabalık bilgiler mevcut

Düzenleyebilirsem örnek bir doya ekleyeyim.
 
Merhaba Halit bey,

Dosyayı ekliyorum.

SIPARIS GENEL DURUM verileri GUNCEL sayfasından çekmekte.
Dosya bu linkte

Teşekkür ederim.
 
Bu kodu bir dene

Kod: 
Sub SendShByEmail()
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String

Sheets(ActiveSheet.Name).Copy Before:=Sheets(1)
Sheets(ActiveSheet.Name).Name = "fffff"

ActiveSheet.DrawingObjects.Delete

Dim X As Range
For Each X In [a1:ar56]
X.Value = X.Value
Next X

ActiveSheet.Copy
ShName = ActiveSheet.Name
WbName = ThisWorkbook.Path & "\" & ShName & ".xls"
ActiveWorkbook.SaveAs WbName
ActiveWorkbook.Close False

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete

Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)
With NewMail
.To = "isim@firma.com"
.To = "isimburaya@firma.com"
.Subject = "Sipairiş Genel Durum"
.Body = "Sipairiş Genel Durum Ektedir. İyi Günler."
.Attachments.Add WbName
.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
Set VBComp = Nothing
Kill WbName
End Sub
 
Son düzenleme:
Kod da yeni düzenlemeler yaptım.

Kod: 
Sub SendShByEmail()
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual

Sheets(ActiveSheet.Name).Copy Before:=Sheets(1)
'Sheets(ActiveSheet.Name).Name = "fffff"

ActiveSheet.Copy
ShName = ActiveSheet.Name

ActiveSheet.DrawingObjects.Delete
Dim X As Range
For Each X In [a1:ar56]
X.Value = X.Value
Next X

WbName = ThisWorkbook.Path & "\" & ShName & ".xls"
ActiveWorkbook.SaveAs WbName
ActiveWorkbook.Close False

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete

Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)
With NewMail
.To = "isim@firma.com"
.To = "isimburaya@firma.com"
.Subject = "Sipairiş Genel Durum"
.Body = "Sipairiş Genel Durum Ektedir. İyi Günler."
.Attachments.Add WbName
.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
Set VBComp = Nothing
Kill WbName

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
 
halit3' Alıntı:
Kod da yeni düzenlemeler yaptım.

Kod: 
Sub SendShByEmail()
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual

Sheets(ActiveSheet.Name).Copy Before:=Sheets(1)
'Sheets(ActiveSheet.Name).Name = "fffff"

ActiveSheet.Copy
ShName = ActiveSheet.Name

ActiveSheet.DrawingObjects.Delete
Dim X As Range
For Each X In [a1:ar56]
X.Value = X.Value
Next X

WbName = ThisWorkbook.Path & "\" & ShName & ".xls"
ActiveWorkbook.SaveAs WbName
ActiveWorkbook.Close False

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete

Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)
With NewMail
.To = "isim@firma.com"
.To = "isimburaya@firma.com"
.Subject = "Sipairiş Genel Durum"
.Body = "Sipairiş Genel Durum Ektedir. İyi Günler."
.Attachments.Add WbName
.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
Set VBComp = Nothing
Kill WbName

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Genişletmek için tıkla ...

En kısa zamanda deneyip dönüş yapacağım Halit bey


Tapatalk kullanarak iPhone aracılığıyla gönderildi
 
Birden fazla mail adresi girebilme ihtimalim var mı?


Tapatalk kullanarak iPhone aracılığıyla gönderildi
 
halit3' Alıntı:
Kod da yeni düzenlemeler yaptım.

Kod: 
Sub SendShByEmail()
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual

Sheets(ActiveSheet.Name).Copy Before:=Sheets(1)
'Sheets(ActiveSheet.Name).Name = "fffff"

ActiveSheet.Copy
ShName = ActiveSheet.Name

ActiveSheet.DrawingObjects.Delete
Dim X As Range
For Each X In [a1:ar56]
X.Value = X.Value
Next X

WbName = ThisWorkbook.Path & "\" & ShName & ".xls"
ActiveWorkbook.SaveAs WbName
ActiveWorkbook.Close False

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete

Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)
With NewMail
.To = "isim@firma.com"
.Subject = "Sipairiş Genel Durum"
.Body = "Sipairiş Genel Durum Ektedir. İyi Günler."
.Attachments.Add WbName
.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
Set VBComp = Nothing
Kill WbName

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Genişletmek için tıkla ...


Bu sorunsuz çalıştı Halit bey,

Teşekkür ederim.

Birden fazla mail adresine göndermek istesem?
 
Kod: 
Sub SendShByEmail()
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual

Sheets(ActiveSheet.Name).Copy Before:=Sheets(1)
'Sheets(ActiveSheet.Name).Name = "fffff"

ActiveSheet.Copy
ShName = ActiveSheet.Name

ActiveSheet.DrawingObjects.Delete
Dim X As Range
For Each X In [a1:ar56]
X.Value = X.Value
Next X

WbName = ThisWorkbook.Path & "\" & ShName & ".xls"
ActiveWorkbook.SaveAs WbName
ActiveWorkbook.Close False

Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete

Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)
With NewMail
.To = "firma@şirketadi" & ";" & "firma@şirketadi" & ";" & "firma@şirketadi" & ";" & "firma@şirketadi" & ";" & "firma@şirketadi"
.Subject = "Sipairiş Genel Durum"
.Body = "Sipairiş Genel Durum Ektedir. İyi Günler."
.Attachments.Add WbName
.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
Set VBComp = Nothing
Kill WbName

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

Bu şekilde birden fazla adrese gönderme işlemi yapıyor Halit bey Teşekkür ederim.
 
Kod: 
Dim X As Range
For Each X In [a1:ar56]
X.Value = X.Value
Next X

kodun yukarıdaki bölümünü aşağıdaki ile değiştirin kod birazcık daha hızlanacaktır.

Kod: 
Dim X As Range
For Each X In [a1:ar56]
If X.HasFormula = True Then
X.Value = X.Value
End If
Next X
 
Uyguladım Halit bey.

Teşekkür ederim.
 
Merhaba Halit Bey,

Mail gönderdik sorun çıkmadı fakat mail alan kişilerde office 2007 ve üzerinde ekteki resim gibi bir sorun çıktı, Office 2003 kullananlarda ise bu uyarıya tamam deyince anlamsız yazılar çıkıyor.

Kod: 
WbName = ThisWorkbook.Path & "\" & ShName & ".xls"

WbName = ThisWorkbook.Path & "\" & ShName & ".xlsx"

yapsam sorun giderilir mi?
 

Ekli dosyalar

  • EXCEL.png
    EXCEL.png
    27.9 KB · Görüntüleme: 3
Son düzenleme:
ActiveWorkbook.SaveAs WbName

yukarıdaki bölümü aşağıdaki ile değiştir.

ActiveWorkbook.SaveAs WbName, FileFormat:=-4143
 
halit3' Alıntı:
ActiveWorkbook.SaveAs WbName

yukarıdaki bölümü aşağıdaki ile değiştir.

ActiveWorkbook.SaveAs WbName, FileFormat:=-4143
Genişletmek için tıkla ...


Halit bey uyguladım resimdeki uyarıları alıyorum ve göndereceği sayfayı hem yeni sayfada Kitap1 olarak açıyor hemde aktif excel kitabının içerisine SIPARIS GENEL DURUM (2) olarak bir sayfa daha açıyor.
 

Ekli dosyalar

  • uyarı.png
    uyarı.png
    14.8 KB · Görüntüleme: 3
  • Run-time error'1004'.png
    Run-time error'1004'.png
    27.5 KB · Görüntüleme: 3
Bir taraflarda karışıklık olmuş
kod:

Kod: 
Sub SendShByEmail()
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual

Sheets(ActiveSheet.Name).Copy

ShName = ActiveSheet.Name

ActiveSheet.DrawingObjects.Delete
Dim X As Range
For Each X In [a1:ar56]
If X.HasFormula = True Then
X.Value = X.Value
End If
Next X

WbName = ThisWorkbook.Path & "\" & ShName & ".xls"

ActiveWorkbook.SaveAs WbName, FileFormat:=-4143
ActiveWorkbook.Close False


Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)
With NewMail
.To = "isim@firma.com"
.To = "isimburaya@firma.com"
.Subject = "Sipairiş Genel Durum"
.Body = "Sipairiş Genel Durum Ektedir. İyi Günler."
.Attachments.Add WbName
.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
Set VBComp = Nothing

Kill WbName

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
 
halit3' Alıntı:
Bir taraflarda karışıklık olmuş
kod:

Kod: 
Sub SendShByEmail()
Dim OutApp As Outlook.Application
Dim NewMail As Outlook.MailItem
Dim ShName As String, WbName As String

Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual

Sheets(ActiveSheet.Name).Copy

ShName = ActiveSheet.Name

ActiveSheet.DrawingObjects.Delete
Dim X As Range
For Each X In [a1:ar56]
If X.HasFormula = True Then
X.Value = X.Value
End If
Next X

WbName = ThisWorkbook.Path & "\" & ShName & ".xls"

ActiveWorkbook.SaveAs WbName, FileFormat:=-4143
ActiveWorkbook.Close False


Set OutApp = New Outlook.Application
Set NewMail = CreateItem(olMailItem)
With NewMail
.To = "isim@firma.com"
.To = "isimburaya@firma.com"
.Subject = "Sipairiş Genel Durum"
.Body = "Sipairiş Genel Durum Ektedir. İyi Günler."
.Attachments.Add WbName
.Save
.Send
End With
Set NewMail = Nothing
Set OutApp = Nothing
Set VBComp = Nothing

Kill WbName

Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Genişletmek için tıkla ...

Üstadım uyguladım sorun olmadı.

Teşekkür ederim.


Tapatalk kullanarak iPhone aracılığıyla gönderildi
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst