Tabelle aufteilen & per LN versenden
13.11.2013 12:00:29
Wolfgang
ich habe bereits viele nützliche Code-Beispiele hier gefunden und verwendet, und es scheint ja nichts unmöglich zu sein - außer für mich mit meinen sehr begrenzten Kenntnissen :-)
Ich habe (aus diesem Forum) einen Code "TabelleAufteilen", mit dem eine umfangreiche Tabelle in mehrere Einzeltabellen aufgeteilt und gleichzeitig unter einem entsprechenden Tabellennamen gespeichert werden. Klappt super, bis hierhin alles ok.
Ich habe einen weiteren Code "MailVersenden", mit dem ich eine Tabelle (die aktuelle, in der der Code hinterlegt ist), über LotusNotes versenden kann. Klappt ja auch gut.
Nun möchte ich aber diese beiden Codes verknüpfen, sprich:
Zuerst sollen die Tabellen aufgeteilt werden, dann soll sofort jede der neu erstellten Tabellen an einen mail-Empfänger versendet werden.
Der mail-Empfänger soll aus einer weiteren Tabelle (oder einem Tabellenblatt) gefunden werden (Querverweis (?)) anhand einer ID, die in der Haupttabelle (der aufzuteilenden) in einer Spalte steht.
Also z.B.:
Zeile A2 bis A20000: Hiernach werden die neuen Tabellen gefiltert und erstellt (siehe auch unten im Code "TabelleAufteilen")
Zeile B2 bis B20000: irgendwelche Daten
Zeile C2 bis C20000: verschiedene ID´s der jeweiligen Empfänger
Der Code "TabelleAufteilen":
Sub TabelleAufteilen()
Dim wkbN As Workbook
Dim shQuelle As Worksheet, shN As Worksheet
Dim rngBereich As Range, rngZelle As Range
Dim strPfad As String, strDatei As String
Dim enmAntwort As VbMsgBoxResult
Dim lngZ As Long
On Error GoTo F
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set shQuelle = ActiveSheet 'ggf. anpassen
With shQuelle
If .FilterMode Then .ShowAllData '.Cells(1).AutoFilter
lngZ = .Cells(Rows.Count, 1).End(xlUp).Row
If lngZ = 1 Then Exit Sub
Set rngBereich = .Range("A1:A" & lngZ)
rngBereich.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Set rngBereich = rngBereich.Resize(rngBereich.Rows.Count - 1).Offset(1).SpecialCells( _
xlCellTypeVisible)
If rngBereich.Cells.Count >= 25 Then
enmAntwort = MsgBox("Es werden " & rngBereich.Cells.Count & " gefilterte Excel- _
Tabellen erstellt." & vbLf _
& "Es kann etwas dauern, bis die gefilterten Excel-Tabellen _
gespeichert sein werden!", vbOK + vbInformation, "Hinweis")
If enmAntwort = vbCancel Then GoTo F
End If
strPfad = Dateidialog
If strPfad = "" Then Exit Sub
Set shN = Workbooks.Add.Sheets(1)
For Each rngZelle In rngBereich
.UsedRange.AutoFilter Field:=1, Criteria1:=rngZelle
.AutoFilter.Range.Copy shN.Cells(1, 1)
strDatei = strPfad & rngZelle & " " & Tabelle2.Range("A1") & ".xlsx"
If Dir(strDatei) "" And enmAntwort vbYes Then
enmAntwort = MsgBox("Die Datei mit dem Namen" & vbLf & "'" & strDatei & "'" & _
vbLf _
& "ist an diesem Speicherort bereits vorhanden." & vbLf _
& "Soll sie und alle weiteren ersetzt werden?", vbYesNo + _
vbCritical)
If enmAntwort = vbNo Then
Exit For
ElseIf enmAntwort = vbYes Then
Application.DisplayAlerts = False
End If
End If
shN.SaveAs strPfad & rngZelle & " " & Tabelle2.Range("A1") & ".xlsx"
shN.UsedRange.Clear
Next
shN.Parent.Close False
.Cells(1).AutoFilter
MsgBox "FERTIG. Es wurden " & rngBereich.Cells.Count & " gefilterte Excel-Tabellen _
unter RD EVA gespeichert." & vbLf _
& "Falls Sie eine weitere Tabelle filtern möchten, müssen Sie dieses Programm _
zunächst schließen (ohne speichern!) und erneut starten.", vbOKOnly + vbInformation, "Hinweis"
End With
F: If Err 0 Then MsgBox Err.Description, , "Fehler-Nr.: " & Err.Number
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Function Dateidialog() As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
fd.InitialFileName = "c:\rdeva\"
fd.Title = "Speichern der gefilterten Einzellisten im Ordner RD EVA, Button SPEICHERN _
klicken"
fd.ButtonName = "SPEICHERN"
If fd.Show = -1 Then Dateidialog = fd.SelectedItems(1) & IIf(Right(fd.SelectedItems(1), 1) = _
"\", "", "\")
End Function
Dann der zweite Code "MailSenden":
Sub mail()
Dim Empfaenger As String
Dim rtitem As Object
Dim EmbeddedObject As Object
Dim Tosenden As String
Dim CCsenden As String
Dim Betreff As String
Dim Text As String
Dim Linkanhang As String
Linkanhang = ThisWorkbook.FullName
Tosenden = Worksheets("tabellenname").Range("b1") 'anpassen
CCsenden = Worksheets("tabellenname").Range("a2") 'anpassen
Betreff = Worksheets("tabellenname").Range("a3") 'anpassen
Text = Worksheets("tabellenname").Range("a4") 'anpassen
On Error GoTo Err_Mail_Click
Dim SessionNotes As Object, NotesDB As Object, NotesDoc As Object
Set SessionNotes = CreateObject("Notes.NOTESSESSION")
Set NotesDB = SessionNotes.GetDatabase("", "")
NotesDB.OPENMAIL
If NotesDB.IsOpen = False Then
MsgBox "Bitte melden Sie sich zunächst vollständig in Notes an!", vbInformation + vbOKOnly
Exit Sub
End If
Set NotesDoc = NotesDB.CreateDocument
With NotesDoc
.Form = "Memo"
.Subject = Betreff
.sendto = Tosenden
.copyto = CCsenden
.body = Text
.DeliveryReport = "B"
.Importance = "2"
.SAVEMESSAGEONSEND = True
.ReturnReceipt = "1"
.Sign = "1"
''''''''''''''''''''''''''''' Dateianhang''''''''''''''''''''''''''''''''''''''''''''''''''''''' _
_
If Trim$(Linkanhang) "" Then
Const embed_ATT = 1454
Set rtitem = .CreateRichTextItem("linkanhang")
Set EmbeddedObject = rtitem.EmbedObject(embed_ATT, "", Linkanhang, "linkanhang")
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' _
_
.Send False
End With
Set SessionNotes = Nothing
Set NotesDB = Nothing
Set NotesDoc = Nothing
Set rtitem = Nothing
Set EmbeddedObject = Nothing
Exit_Mail_Click:
Exit Sub
Err_Mail_Click:
MsgBox Err.Description
Resume Exit_Mail_Click
End Sub
Vielen Dank!
Gruß
Wolfgang