Speichern von Tabellenblättern
28.01.2022 12:06:05
Tabellenblättern
ich bin gerade dabei mir ein Makro zusammen zu schreiben, mit dem ich mehrere Tabellenblätter in eine neue Datei kopieren möchte um diese danach per Mail zu versenden. Einzelne Blätter per Mail versenden hat bisher immer funktioniert und das Kopieren von mehreren Blättern klappt soweit auch schon. Allerdings bricht mir das Makro nach der Abfrage ob ich die Mappe ohne Makros speichern möchte mit dem Fehler 400 ab.
Die Aufgabe meines Makros besteht darin, dass gewissen Blätter aus einer großen Mappe kopiert und versendet werden sollen. Dabei ist mir wichtig, dass die Makros nicht mit gespeichert werden. Zusätzlich muss ich noch zusehen, dass die per PQ erstellten Daten in den kopierten Blättern nicht mehr aktualisiert werden, was zusätzlich beim Aufruf der jeweiligen Seite (Woorksheet.Activate) ständig getan wird.
Was habe ich falsch gemacht bzw. was muss ich ändern, damit das Ganze korrekt abläuft?
Gruß Ulf
Sub TabellenblattKopieren()
Dim strPfad As String, strName As String, strSheets() As String
Dim objWb As Workbook, objWs As Worksheet
Dim lngI As Long
Dim Passwort As String
Dim Mailadresse As String, Betreff As String
Dim olApp As Object
Dim strOldBody As String
Dim AWS As String
Set olApp = CreateObject("Outlook.Application")
Set olMail = olApp.Createitem(0)
MailTo = "u@e.com"
Betreff = strName
Anrede = "Sehr geehrte Damen und Herren,
"
Text = Anrede & Text1
Text1 = "im Anhang finden Sie die aktuellen Umpackkosten."
Passwort = Application.InputBox(prompt:="Geben Sie das Passwort ein", Type:=2)
If Passwort "0000" Then Exit Sub
With Sheets("LG nach Umpackdatum")
strPfad = "\\meinPfad\"
strName = .Range("C1") & " " & .Range("C3") & " " & .Range("D3")
AWS = strName & ".xlsx"
End With
ThisWorkbook.RefreshAll
For Each objWs In ThisWorkbook.Worksheets
If objWs.Name Like "LgGR_?" Then
ReDim Preserve strSheets(lngI)
strSheets(lngI) = objWs.Name
lngI = lngI + 1
End If
Next
If lngI > 0 Then
ThisWorkbook.Sheets(strSheets).Copy
Set objWb = ActiveWorkbook
With objWb
For Each objWs In .Worksheets
objWs.UsedRange = objWs.UsedRange.Value
Next
.SaveAs AWS
End With
End If
With olMail
.GetInspector.Display
strOldBody = .htmlBody
.To = MailTo
.Subject = Betreff
.htmlBody = "" & Text & "" & strOldBody
.Attachments.Add strPfad & AWS
.Display
End With
Set olApp = Nothing
End Sub