HERBERS Excel-Forum - das Archiv
Thema: Tabelle in Intervallen per Mail verschicken | Herbers Excel-Forum
Tabelle in Intervallen per Mail verschicken
Universal
N`Abend zusammen! :-)
Ich würde gern meine Arbeit etwas erleichtern ... meine Kollegen und ich haben eine Excel-Tabelle, die jede Stunde mit Daten gefüllt wird. Wie ich Mails per VBA verschicken kann weiss ich. Leider fehlt mir aber das Wissen um die Tabelle in einem stündlichen Intervall automatisch zu versenden.
Die stündlich aktualisierte Tabelle ändert jeden Tag ihren Namen (<091221 - Daten.xls>, <091222 - Daten.xls>, usw.) und die Daten in diesem Sheet sollen in eine neue Tabelle kopiert werden. Diese Kopie sollte dann jede Stunde per Mail verschickt werden. Danach kann die Arbeitsmappe ohne gespeichert zu werden geschlossen werden.
Was meint ihr, ist das machbar? Über eure Hilfe würde ich mich freuen.
Vielen vielen Dank!
Uni
AW: Tabelle in Intervallen per Mail verschicken
Josef
Hallo Uni,
wie heißt das Tabellenblatt das versendet werden soll?
Gruß Sepp
AW: Tabelle in Intervallen per Mail verschicken
Universal
Hi Sepp,
die Arbeitsmappe verändert mit jedem Tag ihren Namen (siehe Beschreibung oben), das zu kopierende Tabellenblatt heißt "Indeces". In der neuen Arbeitsmappe kann dieses Sheet auch so heißen oder den "default" Wert haben: Sheet1
Dank dir schon mal im Voraus! :-)
Gute Nacht
Uni
AW: Tabelle in Intervallen per Mail verschicken
Josef
Hallo Uni,
ungetestet!
wenn der Code gestartet wird, dann wird jede volle Stunde die Tabelle gemailt.
' **********************************************************************
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopTimer
End Sub
Private Sub Workbook_Open()
Call StartTimer
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public dblNextRunTime As Double
Public Const cstrProzedure = "sendSheet"
Sub StartTimer()
dblNextRunTime = TimeSerial(Hour(Now) + 1, 0, 0)
Application.OnTime earliesttime:=dblNextRunTime, LatestTime:=dblNextRunTime + _
TimeSerial(0, 15, 0), procedure:=cstrProzedure, schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=dblNextRunTime, _
procedure:=cstrProzedure, schedule:=False
End Sub
Sub sendSheet()
'src:= http://www.rondebruin.nl/mail/folder1/mail2.htm
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook, objWb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim strFileName As String, strPath As String
Dim blnWasOpen As Boolean
strPath = "C:\" 'Pfad zur Datei - Anpassen!
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strFileName = Format(Date, "yyMMdd") & " - Daten.xl*"
strFileName = Dir(strPath & strFileName, vbNormal)
If strFileName <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each objWb In Application.Workbooks
If objWb.Name = strFileName Then
Set Sourcewb = objWb
blnWasOpen = True
Exit For
End If
Next
If Sourcewb Is Nothing Then Set Sourcewb = Workbooks.Open(strPath & strFileName)
'Copy the sheet to a new workbook
Sourcewb.Sheets("Indeces").Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007, we exit the sub when your answer is
'NO in the security dialog that you only see when you copy
'an sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
GoTo ErrExit
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
.SendMail "ron@debruin.nl", "This is the Subject line"
On Error GoTo 0
.Close SaveChanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
If Not blnWasOpen Then Sourcewb.Close False
End If
ErrExit:
StartTimer
End Sub
' Modul: DieseArbeitsmappe Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Call StopTimer
End Sub
Private Sub Workbook_Open()
Call StartTimer
End Sub
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public dblNextRunTime As Double
Public Const cstrProzedure = "sendSheet"
Sub StartTimer()
dblNextRunTime = TimeSerial(Hour(Now) + 1, 0, 0)
Application.OnTime earliesttime:=dblNextRunTime, LatestTime:=dblNextRunTime + _
TimeSerial(0, 15, 0), procedure:=cstrProzedure, schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=dblNextRunTime, _
procedure:=cstrProzedure, schedule:=False
End Sub
Sub sendSheet()
'src:= http://www.rondebruin.nl/mail/folder1/mail2.htm
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook, objWb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim strFileName As String, strPath As String
Dim blnWasOpen As Boolean
strPath = "C:\" 'Pfad zur Datei - Anpassen!
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strFileName = Format(Date, "yyMMdd") & " - Daten.xl*"
strFileName = Dir(strPath & strFileName, vbNormal)
If strFileName <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each objWb In Application.Workbooks
If objWb.Name = strFileName Then
Set Sourcewb = objWb
blnWasOpen = True
Exit For
End If
Next
If Sourcewb Is Nothing Then Set Sourcewb = Workbooks.Open(strPath & strFileName)
'Copy the sheet to a new workbook
Sourcewb.Sheets("Indeces").Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007, we exit the sub when your answer is
'NO in the security dialog that you only see when you copy
'an sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
GoTo ErrExit
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
.SendMail "ron@debruin.nl", "This is the Subject line"
On Error GoTo 0
.Close SaveChanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
If Not blnWasOpen Then Sourcewb.Close False
End If
ErrExit:
StartTimer
End Sub
Gruß Sepp
AW: Tabelle in Intervallen per Mail verschicken
Universal
Hi Sepp,
super! Ein besseres Weihnachtsgeschenk kann es kaum geben. Das "Programm" funktioniert einwandfrei!
Vielleicht noch eine kurze Verständnisfrage. Wie könnte ich den "TimeSerial" so ändern, dass ich nicht zur vollen Stunde, sondern beispielsweise um hh:55 die Mail verschicke ... ich würde mir das so vorstellen:
Sub StartTimer()
dblNextRunTime = TimeSerial(Hour(Now) + 1, 0, 0)
Application.OnTime earliesttime:=dblNextRunTime + TimeSerial(0, 55, 0), LatestTime:= _
dblNextRunTime + _
TimeSerial(0, 15, 0), procedure:=cstrProzedure, schedule:=True
End Sub
Sub StartTimer()
dblNextRunTime = TimeSerial(Hour(Now) + 1, 0, 0)
Application.OnTime earliesttime:=TimeSerial(8, 55, 0), LatestTime:=dblNextRunTime + _
TimeSerial(0, 15, 0), procedure:=cstrProzedure, schedule:=True
End Sub
Vielen vielen Dank und ein besinnliches Weihnachtsfest.
Uni
AW: Tabelle in Intervallen per Mail verschicken
Josef
Hallo Uni,
nein so funktioniert das nicht.
Ich würde die OnTime Makros belassen, außer der Zeitanpassung, und die Zeit in der gesendet wird
im Makro zum versenden der Mail einbauen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public dblNextRunTime As Double
Public Const cstrProzedure = "sendSheet"
Sub StartTimer()
dblNextRunTime = TimeSerial(Hour(Now), 55, 0)
Application.OnTime earliesttime:=dblNextRunTime, LatestTime:=dblNextRunTime + _
TimeSerial(0, 15, 0), procedure:=cstrProzedure, schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=dblNextRunTime, _
procedure:=cstrProzedure, schedule:=False
End Sub
Sub sendSheet()
'src:= http://www.rondebruin.nl/mail/folder1/mail2.htm
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook, objWb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim strFileName As String, strPath As String
Dim blnWasOpen As Boolean
'Hier die Zeit der ersten und letzten Ausführung eintragen!
If Time >= TimeSerial(8, 55, 0) And Time < TimeSerial(18, 0, 0) Then
strPath = "C:\" 'Pfad zur Datei - Anpassen!
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strFileName = Format(Date, "yyMMdd") & " - Daten.xl*"
strFileName = Dir(strPath & strFileName, vbNormal)
If strFileName <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each objWb In Application.Workbooks
If objWb.Name = strFileName Then
Set Sourcewb = objWb
blnWasOpen = True
Exit For
End If
Next
If Sourcewb Is Nothing Then Set Sourcewb = Workbooks.Open(strPath & strFileName)
'Copy the sheet to a new workbook
Sourcewb.Sheets("Indeces").Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007, we exit the sub when your answer is
'NO in the security dialog that you only see when you copy
'an sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
GoTo ErrExit
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
.SendMail "ron@debruin.nl", "This is the Subject line"
On Error GoTo 0
.Close SaveChanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
If Not blnWasOpen Then Sourcewb.Close False
End If
End If
ErrExit:
StartTimer
End Sub
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Public dblNextRunTime As Double
Public Const cstrProzedure = "sendSheet"
Sub StartTimer()
dblNextRunTime = TimeSerial(Hour(Now), 55, 0)
Application.OnTime earliesttime:=dblNextRunTime, LatestTime:=dblNextRunTime + _
TimeSerial(0, 15, 0), procedure:=cstrProzedure, schedule:=True
End Sub
Sub StopTimer()
On Error Resume Next
Application.OnTime earliesttime:=dblNextRunTime, _
procedure:=cstrProzedure, schedule:=False
End Sub
Sub sendSheet()
'src:= http://www.rondebruin.nl/mail/folder1/mail2.htm
'Working in 97-2007
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook, objWb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim strFileName As String, strPath As String
Dim blnWasOpen As Boolean
'Hier die Zeit der ersten und letzten Ausführung eintragen!
If Time >= TimeSerial(8, 55, 0) And Time < TimeSerial(18, 0, 0) Then
strPath = "C:\" 'Pfad zur Datei - Anpassen!
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
strFileName = Format(Date, "yyMMdd") & " - Daten.xl*"
strFileName = Dir(strPath & strFileName, vbNormal)
If strFileName <> "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
For Each objWb In Application.Workbooks
If objWb.Name = strFileName Then
Set Sourcewb = objWb
blnWasOpen = True
Exit For
End If
Next
If Sourcewb Is Nothing Then Set Sourcewb = Workbooks.Open(strPath & strFileName)
'Copy the sheet to a new workbook
Sourcewb.Sheets("Indeces").Copy
Set Destwb = ActiveWorkbook
'Determine the Excel version and file extension/format
With Destwb
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007, we exit the sub when your answer is
'NO in the security dialog that you only see when you copy
'an sheet from a xlsm file with macro's disabled.
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
GoTo ErrExit
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
' 'Change all cells in the worksheet to values if you want
' With Destwb.Sheets(1).UsedRange
' .Cells.Copy
' .Cells.PasteSpecial xlPasteValues
' .Cells(1).Select
' End With
' Application.CutCopyMode = False
'Save the new workbook/Mail it/Delete it
TempFilePath = Environ$("temp") & "\"
TempFileName = "Part of " & Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
.SendMail "ron@debruin.nl", "This is the Subject line"
On Error GoTo 0
.Close SaveChanges:=False
End With
'Delete the file you have send
Kill TempFilePath & TempFileName & FileExtStr
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
If Not blnWasOpen Then Sourcewb.Close False
End If
End If
ErrExit:
StartTimer
End Sub
Gruß Sepp
AW: Tabelle in Intervallen per Mail verschicken
Universal
Hi Sepp,
danke für die schnelle Antwort. Na gut, hätte ja sein können, dass ich doch ein bisschen was zu beitragen kann. ;-)
Nochmals vielen Dank & viele Grüße
Uni
Excel-Beispiele