Hallo alle zusammen.
Da man in dem Titel leider beschränkt ist mit den Zeichen, alles weitere hier
Ich hab die letzten Wochen / Monate folgendes Makro zusammengebaut / gebastelt mit viel Hilfe aus diesem Forum:
Sub Mail()
'Deklaration der Variablen
Dim Zei1 As Long
Dim Zei2 As Long
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim wkb As Workbook
Dim colC As New Collection
Dim colPostp As New Collection
Dim Spa1 As Long
Dim S As Integer 'Variable für eine Schleife
Dim Z As Long 'Variable für eine Schleife
Dim sWks As String 'Variable für den Blattnamen
Dim sFile As String 'Variable für den Dateinamen
Dim Pfad As String 'Variable für den Pfad, wo gespeichert werden soll
Dim Empfaenger As String 'Variable für den Empfänger der E-Mail
Dim anzahl As Integer 'Variable für die Anzahl der Suchbegriffe
Dim Such As Variant 'variables Array für die Suchbegriffe
Dim strSuch As String 'Variable für den Suchbegriff
Dim intTMP As Integer 'Variable für eine Schleife zur Trennung der Suchbegriffe
Dim Str As String 'Variable für den ersten Teil der E-Mail Adresse
Dim Maildb As Object 'Variable für die LoNo DB
Dim UserName As String 'Variable für den LoNo Nutzernamen
Dim MailDbName As String 'Variable für den Namen der LoNo DB
Dim MailDoc As Object 'Variable für das Mail Objekt
Dim Session As Object 'Variable für die LoNo Session
Dim workspace As Object
Dim Anhang As Object
Dim attachment As String
Dim Attachme As Object
'Deklaration der Arbeitsmappe, die durchsucht werden soll
Set wks1 = Worksheets("CM")
'Einrichten des Arrays mit den Statusmeldungen
'Möglichkeit zur Eingabe mehrere Statusmeldungen
'Ebenfalls Abbruchbedingung, falls Eingabefeld leergelassen wird
strSuch = InputBox( \_
prompt:="Bitte den Status eingeben." & vbCr & vbCr & "Für mehrere, bitte Trennung NUR mit Komma, jedoch OHNE Leerzeichen." & vbCr & vbCr & "Freilassen für Abbruch", \_
Default:=" z.B. open,postponed,in progress,done")
'Abbruchbedingung falls Feld leer gelassen wird
If strSuch = "" Then Exit Sub
'Trennung des Strings der Suchbegriffe anhand des Trennzeichens, hier: ein "," - Komma
Such = Split(strSuch, ",")
For intTMP = 0 To UBound(Such)
Debug.Print Trim(Such(intTMP))
Next intTMP
anzahl = UBound(Such) - LBound(Such)
Worksheets.Add after:=Worksheets(Worksheets.Count)
'wks2 als aktive Arbeitsmappe setzen
Set wks2 = ActiveSheet
'Beginn Sortier- / Filtervorgang
With wks1
Zei1 = .Cells(Rows.Count, 9).End(xlUp).Row
Spa1 = .Cells(1, Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, 1), .Cells(1, Spa1)).Copy Destination:=wks2.Cells(1, 30)
For S = 0 To anzahl
wks2.Cells(2, 41).Value = Such(S)
For Z = 2 To Zei1
If .Cells(Z, 12).Value = Such(S) Then
On Error Resume Next
colC.Add Key:=.Cells(Z, 9).Value, Item:=.Cells(Z, 9).Value
On Error GoTo 0
End If
Next Z
'Erstellen eines neuen Arbeitsblattes im aktiven Dokument mit einfügen der
'Daten, die den Kriterien entsprechen
For Z = 1 To colC.Count
wks2.Range("A:X").Clear
wks2.Cells(2, 38).Value = colC(Z)
.Range(.Cells(1, 1), .Cells(Zei1, Spa1)).AdvancedFilter Action:=xlFilterCopy, \_
CriteriaRange:=wks2.Range(wks2.Cells(1, 30), wks2.Cells(2, 29 + Spa1)), \_
CopyToRange:=wks2.Range("A1"), Unique:=False
wks2.Range("A:X").WrapText = False
wks2.Range("A:X").EntireColumn.AutoFit
'Ab hier wird die neu erstellte Liste in eine neue Datei kopiert und
'sowohl Blatt- als auch Dateinamen können vergeben werden
Application.ScreenUpdating = False
'Abschneiden des ersten Teils der E-Mail Adresse zur Vorgabe des Blatt- und Dateinamens
Str = wks2.Cells(2, 38)
If InStr(Str, "@") \> 0 Then
Str = Left(Str, InStr(Str, "@") - 1)
Else
Str = Left(Str, InStr(Str, "/") - 1)
End If
'Inputbox zur Abfrage des neuen Blattnamens
sWks = InputBox( \_
prompt:="Bitte Blattnamen eingeben." & vbCr & vbCr & "Freilassen für Abbruch.", \_
Default:=Date & " - " & Such(S))
'Abbruchbedingung, falls Feld leergelassen wird
If sWks = "" Then Exit Sub
'Inputbox zur Abfrage des neuen Dateinamens
sFile = InputBox( \_
prompt:="Bitte den Dateinamen OHNE Endung (.xls) eingeben." & vbCr & vbCr & "Freilassen für Abbruch.", \_
Default:=sWks & " - " & Str & ".xls")
'Abbruchbedingung, falls Feld leergelassen wird
If sFile = "" Then Exit Sub
'Erstellen des neuen Pfades, falls noch nicht vorhanden
Pfad = ActiveWorkbook.Path & "\" & Str
If Dir(Pfad, vbDirectory) = "" Then
MkDir (Pfad)
Else
End If
' Kopieren und speichern in einer neuen Datei mit den vorher getätigten Angaben
ActiveSheet.Copy
ActiveSheet.Name = sWks
ActiveWorkbook.SaveAs Pfad & "\" & sFile
Application.ScreenUpdating = True
' Öffnen des Notes Clients und Anhängen der neuen Datei
' Als Empfänger wird die E-Mail Adresse genommen, die in der Tabelle eingetragen ist
Empfaenger = Worksheets(sWks).Range("I2")
'Starten der Notes Session und setzen der benötigten Variablen
'Variable UserName setzen anhand des Nutzernamens, der gerade angemeldet ist
Set Session = CreateObject("Notes.NotesSession")
UserName = Session.UserName
'Name der Notes DB herausfinden anhand des Namens der Mail Datenbank
MailDbName = Left$(UserName, 1) & Right$(UserName, \_
(Len(UserName) - InStr(1, UserName, " "))) & ".nsf"
Set Maildb = Session.GetDatabase("", MailDbName)
'LoNo Mail DB öffnen, falls noch nicht offen
If Not Maildb.IsOpen Then Maildb.OpenMail
'Neues LoNo Dokument erstellen
Set MailDoc = Maildb.CreateDocument
'Die Art des LoNo Dokumentes festlegen, hier: Memo (Standard Mail)
MailDoc.Form = "Memo"
'Setzen des EMpfängers anhand des vorher aus der Tabelle gefilterten Empfängers
MailDoc.SendTo = Empfaenger
'Betreff der Mail festlegen anhand von Datum, durchsuchtem Status und Empfänger
MailDoc.Subject = sWks
'Text des Body Feldes festlegen anhand des Suchbegriffs
Select Case Such(S)
Case "open"
MailDoc.Body = (wks1.Cells(2, 29).Value & Chr(10) & Chr(10) & wks1.Cells(3, 29).Value & Chr(10) & Chr(10) & wks1.Cells(4, 29).Value & Chr(10) & Chr(10) & wks1.Cells(7, 29).Value & Chr(10) & Chr(10) & wks1.Cells(8, 29).Value)
Case "postponed"
MailDoc.Body = (wks1.Cells(2, 29).Value & Chr(10) & Chr(10) & wks1.Cells(3, 29).Value & Chr(10) & Chr(10) & wks1.Cells(5, 29).Value & Chr(10) & Chr(10) & wks1.Cells(7, 29).Value & Chr(10) & Chr(10) & wks1.Cells(8, 29).Value)
Case "in progress"
MailDoc.Body = (wks1.Cells(2, 29).Value & Chr(10) & Chr(10) & wks1.Cells(3, 29).Value & Chr(10) & Chr(10) & wks1.Cells(6, 29).Value & Chr(10) & Chr(10) & wks1.Cells(7, 29).Value & Chr(10) & Chr(10) & wks1.Cells(8, 29).Value)
End Select
'Variable attachment auf das anzuhängende File setzen
attachment = Pfad & "\" & sFile
Set Attachme = MailDoc.CreateRichTextItem("Attachment")
'Das Attachment an die Mail hängen
Set Anhang = Attachme.EmbedObject(1454, "", attachment, "Attachment")
'Festlegen, das die gesendete Mail gespeichert werden soll (nach dem senden)
MailDoc.SaveMessageOnSend = True
Set workspace = CreateObject("Notes.NotesUIWorkspace")
'Ins Body Feld der Mail gehen
Call workspace.EDITDOCUMENT(True, MailDoc).GOTOFIELD("Body")
Set Maildb = Nothing: Set MailDoc = Nothing: Set Session = Nothing
'Schliessen der neu geöffneten Arbeitsmappe und der neuen Datei ohne Abfrage
ActiveWorkbook.Close True
Next Z
Next S
'Löschen des angelegten Arbeitsblattes
Application.DisplayAlerts = False
ActiveSheet.Delete
Application.DisplayAlerts = True
End With
End Sub
Das funktioniert auch alles soweit super. Was ich jetzt lediglich ändern möchte, weil ich da meinen Auftraggeber falsch verstanden habe ist, die Spalte, in der nach dem eingegebene Suchbegriff gesucht werden soll.
Sprich hier diese Zeile:
If .Cells(Z, 12).Value = Such(S) Then
Z Ist ja der Wert der Zeile, und 12 der Wert der Spalte, der auch weiterhin konstant ist, nun aber nicht mehr der Spalte 12 entspricht, sondern der Spalte 15. Änder ich jedoch diesen Wert wird im späteren Kopiervorgang NICHTS mehr kopiert, als ob er nichts mehr findet. Ich kann die Inhalte der Spalten kopieren, also dass kein Datenunterscheid vorhanden ist, dies ändert nichts, es wird nichts mehr kopiert. Auch im Debugger sehe ich bis zu
.Range(.Cells(1, 1), .Cells(Zei1, Spa1)).AdvancedFilter Action:=xlFilterCopy, \_
CriteriaRange:=wks2.Range(wks2.Cells(1, 30), wks2.Cells(2, 29 + Spa1)), \_
CopyToRange:=wks2.Range("A1"), Unique:=False
keine Unterschied. Was genau „in“ diesem Kopiervorgang passiert, seh ich leider ja nicht, aber da das Ergebnis nichts auswirft, kann ja auch nicht viel passiert sein.
Der Copy Befehl muss wohl irgendwie Schwierigkeiten haben, oder es ist was anderes, was ich aber jetzt auch nach tagelangen Testläufen und Versuchen nicht finde und für mich auch nicht nachvollziehbar ist. Ich finde keinen anderen Bezug auf diese Spalte oder den Inhalt dort, den man mitändern müsste.
Ich hoffe jmd kann einen Fehler finden, oder mir erklären, warum dies so passiert. Das Makro hat mich schon genug Stunden, Schweiss, Tränen und Energy Drinks gekostet
LG
Ralf