Suche und Kopieren in VBA Script geht nicht

Hallo alle zusammen.
Da man in dem Titel leider beschränkt ist mit den Zeichen, alles weitere hier :smile:

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 :smiley:

LG
Ralf

Hallo Ralf,

Da man in dem Titel leider beschränkt ist mit den Zeichen,
alles weitere hier :smile:

ja, zustimm, paar mehr Zeichen, so 5- 10 wären schon schick :smile:

Ich habe jetzt den Code überflogen, der ist mir zu heftig.
Kannst du den mal gewaltig kürzen aber so daß es lauffähig bleibt?
Du sagst es geht da um ein Suchen- und Kopierproblem.
Also ist doch alles was da die Lotus Notes mail betriftt nicht wichtig, kann weg.

Vielleicht auch noch anderes. Übrig bleiben sollte ein Code der funktioniert.
Bis halt auf den Fehler daß er seltsam reagiert wenn du da die Spalte von 12 auf 15 änderst oder wie das war.

Und den in eine Beispielmappe einbinden, die ein Blatt „CM“ hat usw.
Die Datenmenge = Zeilen kannst du reduzieren und anonymisieren.
Wichtig ist daß die tabellenstruktur = Spalten erhalten bleibt.

Alle für die Anfrage unwichtigen Spalten rechts von den wichtigen Spalten kannste auch löschen.
Hochladen der mappe mit http://www.uploadagent.de/ o.ä.

Gruß
Reinhard