Sub Makro7()
Dim Zeile As Integer
Dim Spalte As Integer
Dim ZelleK As Integer
Const Auswahl As String = "x"
Dim Wert As String
Zeile = InputBox("Geben Sie eine Zahl zwischen 2 und 7 ein", "Test", "2")
If Zeile > 1 Then
If Zeile < 8 Then
Spalte = 1
ActiveWorkbook.Save
Workbooks("Registrierung.xlsm").Worksheets("Liste").Activate
Wert = Workbooks("Registrierung.xlsm").Worksheets("Trackingliste").Cells(Zeile, Spalte).Value
If Wert = Auswahl Then
Range("B" & Zeile & ":Q" & Zeile).Select
Selection.Copy
End If
Workbooks.Open Filename:="P:\Neu\Email.xls"
Sheets("Liste").Select
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close
With Selection.Interior
.Pattern = xlNone
End With
ActiveWorkbook.Save
Dim outApp As Object
Dim outMail As Object
Set outApp = CreateObject("Outlook.Application")
Set outMail = outApp.CreateItem(0)
With outMail
.To = "xx@info.com"
.CC = "yy@info.com"
.Subject = "Eingang"
.Body = "Hallo Frau XX," & Chr(13) & _
"anbei ein eingegangener Fall ..." & Chr(13) & _
"Viele Grüße" & Chr(13) & Chr(13)
.ReadReceiptRequested = True
.Attachments.Add "P:\Neu\Email.xls"
.Display
End With
Set outApp = Nothing
Set outMail = Nothing
End If
End If
End Sub