Sub Makro7()
Dim Zeile As Integer
Dim Spalte As Integer
Dim ZelleK As Integer
Const Auswahl As String
Dim Wert As String
Auswahl = "x"
Zeile = 2
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("B1:Q1").Select
Range("B1:Q1", "B5:Q5").Select
Range("B5").Activate
Selection.Copy
Range("A1").Select
ActiveSheet.Cells(Rows.Count, ActiveCell.Column).Select
If IsEmpty(ActiveCell) Then
ActiveCell.End(xlUp).Select
aH = ActiveCell.Row
a = aH + 1
b = ActiveCell.Column
End If
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
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
End Sub