AW: Outlook 2010 senden & an CC
31.10.2011 18:26:35
Heinz
Hallo Hajo
Das wäre nun mein Code
Option Explicit
Sub einzelnes_blatt_senden()
If ActiveWorkbook.Name ThisWorkbook.Name Then Exit Sub
Dim strTabelle As String ' Variable für den Tabellennamen
Dim wsTabelle As Worksheet ' Variable für die Tabelle als Objekt
' Tabelle2 als Standard festlegen
'ActiveSheet.DrawingObjects.Visible = False
strTabelle = "Personalbesetzung"
' Name der zu versendenen Tabelle abfragen
'strTabelle = InputBox("Welches Blatt möchten Sie senden?" & vbCrLf & _
'vbCrLf & "Bitte den Tabellennamen eingeben", , strTabelle)
' kein Abbruch der Eingabe
If strTabelle "" Then
' Schleife über alle Arbeitsblätter
For Each wsTabelle In ThisWorkbook.Sheets
' Name der Tabelle entspricht dem der zu versendenen Tabelle
If wsTabelle.Name = strTabelle Then
' Bildschirmaktualisierung aus
Application.ScreenUpdating = False
' Tabelle komplett kopieren
Sheets(strTabelle).Copy
' Alles in der Copy im Tabellenblatt löschen
ActiveSheet.Shapes("Heinz1").Delete
Dim Ding As Object
For Each Ding In ActiveWorkbook.VBProject.VBComponents
'Type 100 = DieseArbeitsmappe und alle Tabellen
If Ding.Type = 100 Then
With ActiveWorkbook.VBProject.VBComponents(Ding.Name).CodeModule
.DeleteLines 1, .CountOfLines
Range("W5:Z19,Z40,B51:B95,Y51:Z72").Select
Selection.Interior.ColorIndex = xlNone
Selection.ClearContents
Range("W5").Select
With Selection.Validation
.Delete
.Add Type:=xlValidateInputOnly, AlertStyle:=xlValidAlertStop, Operator _
:=xlBetween
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
Selection.Interior.ColorIndex = xlNone
Selection.Font.ColorIndex = 0
ActiveWindow.SmallScroll Down:=42
Range("Y51:Z72").Select
Selection.Interior.ColorIndex = xlNone
Selection.Font.ColorIndex = 0
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
ActiveWindow.SmallScroll Down:=-93
Range("Y5").Select
End With
End If
Next
'aktive Arbeitsmappe mit Mailbenachrichtigung "Diese Tabelle wurde als Mail versandt" versenden
ActiveWorkbook.SendMail ThisWorkbook.Worksheets("Personalbesetzung").Cells(14, _
26), "Personalbesetzung" & _
" " & Worksheets("Personalbesetzung").Cells(5, 17) & " Schicht " & Worksheets(" _
Personalbesetzung").Cells(5, 21)
ActiveWorkbook.SendMail ThisWorkbook.Worksheets("Personalbesetzung").Cells(10, _
26), "Personalbesetzung" & _
" " & Worksheets("Personalbesetzung").Cells(5, 17) & " Schicht " & Worksheets(" _
Personalbesetzung").Cells(5, 21)
' aktive Arbeitsmappe schließen ohne Speichern
ActiveWorkbook.Close False
' Bildschirmaktualisierung ein
Application.ScreenUpdating = True
' Schleife verlassen
Exit For
Else
' Tabelle mit dem eingegebenen Namen ist nicht vorhanden
If wsTabelle.Name = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name Then _
MsgBox "Diese Tabelle gibt es nicht"
End If
Next wsTabelle
End If
'ActiveSheet.DrawingObjects.Visible = True
End Sub
Gruß
Heinz