Hallo Way,

wie gesagt ich kann es nicht testen, müsste sonst alles nachbauen, aber noch ein ansatz

Sub Makro7()
   '
   ' Makro7 Makro
   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
         'ZelleK = 2
         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
            '.TintAndShade = 0
            '.PatternTintAndShade = 0
         End With
         ActiveWorkbook.Save
       
         Dim outApp As Object
         Dim outMail As Object
         Set outApp = CreateObject("Outlook.Application")
         Set outMail = outApp.CreateItem(0)
         With outMail
            'Empfänger
            .To = "xx@info.com"
            .CC = "yy@info.com"
            '.BCC = ""
            'Betreff
            .Subject = "Eingang"
            'Nachricht
            .Body = "Hallo Frau XX," & Chr(13) & _
                    "anbei ein eingegangener Fall ..." & Chr(13) & _
                    "Viele Grüße" & Chr(13) & Chr(13)
            'Lesebestätigung aus
            .ReadReceiptRequested = True
            'Dateianhang
            .Attachments.Add "P:\Neu\Email.xls"
            .Display
         End With
         Set outApp = Nothing
         Set outMail = Nothing
      End If
   End If
End Sub

Gruß Detlev