Tabellen per EMail versenden - @wuxinese
29.08.2007 09:04:51
Fritz_W
der ursprüngliche Thread mit meinem Beitrag vom 23.08. wurde inzwischen geschlossen. Deshalb möchte ich an dieser Stelle mein Anliegen noch einmal aufgreifen.
Ich möchte ausgewählte Tabellen einer Exceldatei an mehrere eMail-Anschriften versenden, wobei die Formeln in den betreffenden Tabellen in der zu versendenden Datei in Werte umgewandelt werden müssen. In der Tabelle "Daten" werden sowohl die Empfänger (E-Mail-Anschriften im Bereich F6:F55) als auch die zu versendenden Tabellen der Datei (V2:V5) festgelegt.
Rainer ("wuxinese") hat mir hierzu den nachstehenden Code geschrieben, der der von mir (beschriebenen) Aufgabenstellung gerecht wird und wofür ich mich bei ihm an dieser Stelle nochmals ganz herzlich bedanken möchte.
Nun hätte ich ggf. noch einen Änderungswunsch:
Einzelne der zu versendenden Tabellenblätter enthalten im Modul der jeweiligen Tabelle Code, der ebenfalls "entfernt" werden sollte. Würde mich freuen, wenn ihr mir hierzu noch hilfreiche Vorschläge unterbeiten könntet.
Vielen Dank für jede Form von Hilfe.
mfg
Fritz
Hier Rainers Code:
Sub VersandTab()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim ich, fort As Workbook
Dim blatt As Worksheet
Set ich = ThisWorkbook
Set fort = Workbooks.Add
Application.DisplayAlerts = False
fort.Worksheets(4).Delete
fort.Worksheets(3).Delete
fort.Worksheets(2).Delete
fort.Worksheets(1).Name = "WRZLBRNFT"
For i = 2 To 5
With ich.Worksheets("Daten")
If .Cells(i, "v").Text "" Then
ich.Worksheets(.Cells(i, "v").Text).Copy after:=fort.Worksheets(fort.Worksheets. _
_
Count)
Set blatt = fort.Worksheets(fort.Worksheets.Count)
blatt.UsedRange.Copy
blatt.Range(blatt.UsedRange.Address).PasteSpecial xlPasteValuesAndNumberFormats
blatt.Shapes(1).Delete
Set blatt = Nothing
End If
End With
Next i
If fort.Worksheets.Count = 1 Then GoTo NixKopiert
fort.Worksheets("WRZLBRNFT").Delete
Dim anz_used As Double
Dim empf() As String
anz_used = 0
With ich.Worksheets("Daten")
For i = 6 To 55
If .Cells(i, "f").Text "" Then
If anz_used = 0 Then
ReDim empf(0)
Else
ReDim Preserve empf(UBound(empf) + 1)
End If
empf(anz_used) = .Cells(i, "f").Text
anz_used = anz_used + 1
End If
Next i
If anz_used 0 Then
fort.SendMail empf, "Aktuelle Infos zum Tabellentippspiel", True
End If
End With
NixKopiert:
fort.Close False
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub