Hücre icerisindeki veriye göre Elektronik posta gönderilsin

kaleci · 30 Mayıs 2019

Merhaba arkadaşlar,

Sizlerin yardımına ihtiyacım var. Biz itfaiye görevlileri olarak, tespit ettiğimiz eksiklikleri excel tablosuna kaydediyoruz. Tespit edilen eksikliklerin giderilmesi için 3 arkadaşımız ilgileniyor. Tabii ki eksiklikler hergün kaydedildiği gibi haftada 1 veya 2 defa da kaydedilebiliyor. Arkadaşlar hergün excel tablosuna bakmak zorunda kaliyor.

Eger Soru 1 deki düşüncemizi gerçekleştirebilirsek, arkadaşlar elektronik postaya hergün bakmak zorunda kalmazlar, işlerimizi kolaylaştırmış oluruz.

Soru 1: excelde (N6:N…- sonsuz a kadar) hücreye „acik“ kaydı yapılırsa, otomatik olarak B1 hücresindeki Mail adreslerine B2 hücresindeki Metin, Mail olarak gönderilsin.

Soru 2: N6:N…- sonsuz a kadar olan hücreye „calisiliyor“ yazılırsa, A7:N7 deki veriler, kesilip calisiliyor Tablosuna yapıştırılsın, Veya
N6:N…- sonsuz a kadar olan hücreye „kapatildi“ yazılırsa, A7:N7 deki veriler, kesilip kapatildi Tablosuna yapıştırılsın.

Yardımcı olursanız memnun olurum.

Dosya

kaleci · 30 Mayıs 2019

Merhaba arkadaslar,

Office-loesung da bir Kod buldum otomatik olarak Mail göndermiyor ama biraz degisiklik yapilabilirse, bize yardimci olabilir.
1. Bu koda N6:N500... hücresine "acik" yazilirsa otomatik olarak Mail göndersin emrini ekleyebilirsek güzel olur.

Kod:

Sub Send_Excel_Message()
Dim MyMessage As Object, MyOutApp As Object
'InitializeOutlook = True
Set MyOutApp = CreateObject("Outlook.Application")
'Nachrichtenobject erstellen
Set MyMessage = MyOutApp.CreateItem(0)
With MyMessage
.To = "abc@firma.com"
.Subject = "Testmeldung von Excel2016 " & Date & Time
'Hier wird eine normale Text Mail erstellt
'.body = "Das ist ein Test" & vbCrLf & "Bitte ignorieren"
'Hier wird die HTML Mail erstellt
.HTMLBody = "Das ist ein Test." & vbCrLf & "Bitte ignorieren."
'Hier wird die Mail nochmals angezeigt
.Display
'Nicht ganz offiziell
.Save
SendKeys "%S"
End With
MyOutApp.Quit
Set MyOutApp = Nothing
Set MyMessage = Nothing
End Sub

kaleci

kaleci · 30 Mayıs 2019

Arkadaslar,

Soru 1 i E-Mail gönderilmesini asagidaki Kod ile cözebildim. Soru 2 ye yardimci olursaniz memnun olurum.

Kod:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngT As Range, c As Range
    Set rngT = Intersect(Range(Cells(5, 14), Cells(ActiveSheet.Rows.Count, 14)), Target)
    If Not rngT Is Nothing Then
        For Each c In rngT
            If c.Value = "acik" Then
                sendeEMail
                Exit Sub
            End If
        Next
    End If
End Sub


Sub sendeEMail()
Dim oApp As Object
Dim strSignatur As String

   Set oApp = CreateObject("OUTLOOK.Application")
   With oApp.CreateItem(0)    'leere E-Mail ohne Vorlage
      
      'Signatur anzeigen + auslesen
      .GetInspector.Display
      strSignatur = .Body
      
      .To = Range("B1").Value
      .Subject = "Mängelanzeige"
      .Body = "Neue Mangel: Bitte kontrollieren Sie die Excelliste" & vbLf & strSignatur
      
      '.Display    'Anzeigen
      .Send       'Abschicken
   End With
  
End Sub

kaleci