Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Tabelle in Intervallen per Mail verschicken | Herbers Excel-Forum


Betrifft: Tabelle in Intervallen per Mail verschicken von: Universal
Geschrieben am: 21.12.2009 22:52:23

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

  

Betrifft: AW: Tabelle in Intervallen per Mail verschicken von: Josef Ehrensberger
Geschrieben am: 21.12.2009 23:03:13

Hallo Uni,

wie heißt das Tabellenblatt das versendet werden soll?


Gruß Sepp



  

Betrifft: AW: Tabelle in Intervallen per Mail verschicken von: Universal
Geschrieben am: 22.12.2009 00:05:23

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


  

Betrifft: AW: Tabelle in Intervallen per Mail verschicken von: Josef Ehrensberger
Geschrieben am: 22.12.2009 07:58:10

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



Gruß Sepp



  

Betrifft: AW: Tabelle in Intervallen per Mail verschicken von: Universal
Geschrieben am: 22.12.2009 20:40:14

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
Oder angenommen, ich möchte, dass die Intervalle erst um 8:55 Uhr beginnen und dann jede Stunde ausgelöst werden ...
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
Würde das so hinkommen? :-)

Vielen vielen Dank und ein besinnliches Weihnachtsfest.
Uni


  

Betrifft: AW: Tabelle in Intervallen per Mail verschicken von: Josef Ehrensberger
Geschrieben am: 22.12.2009 20:59:42

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


Gruß Sepp



  

Betrifft: AW: Tabelle in Intervallen per Mail verschicken von: Universal
Geschrieben am: 22.12.2009 22:03:26

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


Beiträge aus den Excel-Beispielen zum Thema "Tabelle in Intervallen per Mail verschicken"