Zellen auslsen und per Outlock verschicken

[Balu2202]

Hallo Excel Gemeinde,

ich bin neu hier im Forum und auf ein VBA Script gestoßen was schon ganz nah an dem ist was ich aktuell umsetzen möchte.

Grundsätzlich will ich eine Excel Liste auslesen und per Outlook verschicken. Allerdings habe ich aktuell gerade Schwierigkeiten mit der Umsetzung im Detail. In dem Script/Makro das ich gefunden habe steht in der ersten Zeile eine Überschrift und das Makro fängt dann in Zeile 2 an zu arbeiten. Mein endgültiges Sheet hat aber in den Zeilen 1-7 Text stehen und muss dann erst ab Zeile 8 anfangen zu arbeiten. Ich komme da nicht drauf wie/wo man das angeben kann. Dafür habe ich leider zu wenig Ahnung.

Wäre schön wenn mich hier jemand unterstützen könnte.

Hier der Link zum ursprünglichen Thread: http://www.clever-excel-forum.de/thread-...age-2.html

Und dann auch die Datei im Anhang.
Gerne auch den Code wenn er gewünscht wird.

[Balu2202]

Code:

Hier dann noch der Code:
Option Explicit

Sub Excel_Serial_Mail()
   Dim MyMessage As Object, MyOutApp As Object
   Dim SavePath As String
   Dim strgBody As String
   Dim AWS As String
   Dim i As Long, lngZ As Long
  strgBody = Sheets("Tabelle2").Range("A1").Value
  With Sheets("Tabelle1")
     lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
     If lngZ > 1 Then
        .Range(.Cells(2, 1), .Cells(lngZ, 17)).ClearContents
     End If
  End With
  With Sheets("Liste Namen")
     lngZ = .Cells(.Rows.Count, 18).End(xlUp).Row
  End With

  Sheets("Tabelle1").Select
  For i = 3 To lngZ
        With Sheets("Liste Namen")
           Range(Cells(2, 1), Cells(2, 17)).Value = .Range(.Cells(i, 2), .Cells(i, 18)).Value
        End With
            SavePath = "D:\Persönliche Daten\Desktop\Schiedsrichter Obmann NBSV\Umpire Liste\Listen für Schiedsrichter\" '"E:\Eigene Dateien"
      'Kopiert aktuelles Sheet in eine neue Mappe
      'welche nur diese Tabelle enthält
      ActiveSheet.Copy
      'Speichert die Datei unter dem Tabellennamen und einem Zeitstempel
     ActiveWorkbook.SaveAs Filename:=Range("A2") & " " & Format(Date, "dd.mm.yyyy") & ".xls"
      'Mappenname wird an Variable übergeben
      'und anschliessend gleich geschlossen
      With ActiveWorkbook
          AWS = .FullName
          .Close
      End With
     Set MyOutApp = CreateObject("Outlook.Application")
     Set MyMessage = MyOutApp.CreateItem(0)
     With MyMessage
         'Der Empfänger stehet in Spalte Q in Zeile 2
         .To = Cells(2, 17).Value 'E-Mail Adresse
         'Der Betreff in Spalte B
         .Subject = "Lizenzstatus Schiedsrichter Baseball" '"Betreffzeile"
         .Attachments.Add AWS
         'Der zu sendende Text in Spalte C
         'Maximal 1024 Zeichen
         'Der Text wird ohne Formatierung übernommen
         .Body = strgBody
         'Hier wird die Mail angezeigt
         '.Display
         'Hier wird die Mail gleich in den Postausgang gelegt
         .Send
     End With
     
     Application.DisplayAlerts = False
     'Objectvariablen leeren
     MyOutApp.Quit
     Set MyOutApp = Nothing
     Set MyMessage = Nothing
     'Sendepause einschalten
     'Outlook kann die Aufträge nicht schnell genug verarbeiten
     Application.Wait (Now + TimeValue("0:00:05"))
     Kill AWS
     Application.DisplayAlerts = True
  Next i
   
End Sub