Per Makro: Tabellenteile in neue .xlsx

Sub DateiErstellenUndVersenden() Dim Suche1, Suche2, Suche3, Suche4, Suche5, Speicherort As String Suche1 = "Fuchs" Speicherort = "C:\Users\Ich\Documents\" 'Runde 1 'Filtern nach Fuchs ActiveSheet.Range("$A$7:$K$184").AutoFilter Field:=4, Criteria1:= _ Suche1 Range("A7").CurrentRegion.Offset(0, 0).SpecialCells(xlCellTypeVisible).EntireRow.Copy MsgBox ("Daten kopiert.") ' Neue xlsx geöffnet und Daten eingefügt Workbooks.Add Range("A1").Select ActiveSheet.Paste 'Datei Speichern und Schliessen ActiveWorkbook.SaveAs Filename:=Speicherort & " " & Suche1, FileFormat:= _ xlOpenXMLWorkbook, CreateBackup:=False ActiveWindow.Close MsgBox ("Filterdaten gespeichert unter C:\Users\Ich\Documents\") 'Wechsel in Urdatei, entfiltern Windows("Originaldatei.xlsm").Activate Range("A1").Select ActiveSheet.ShowAllData 'dann käme Runde 2 usw. End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub DateiErstellenHerber() Dim Speicherort As String Dim zelle, spalte As Range Dim letzte As Long With ThisWorkbook.Worksheets(1) letzte = .Cells(.Rows.Count, 1).End(xlUp).Row Set spalte = .Range("A1:A" & letzte) End With Speicherort = "C:\Users\Ich\Documents\" inpBox = Application.InputBox("Bitte Suchkriterium eingeben:") If inpBox "" Then For Each zelle In spalte If inpBox = zelle.Value Then 'Filtern nach Zwergenk. und Kopieren ActiveSheet.Range("$A$1:$D$20").AutoFilter Field:=1, Criteria1:= _ inpBox Range("A1").CurrentRegion.Offset(0, 0).SpecialCells(xlCellTypeVisible).EntireRow. _ Copy MsgBox ("Daten kopiert.") ' Neue xlsx geöffnet und Daten eingefügt Workbooks.Add Range("A1").Select ActiveSheet.Paste 'Datei Speichern und Schliessen ActiveWorkbook.SaveAs Filename:=Speicherort & inpBox, FileFormat:= _ xlOpenXMLWorkbook, CreateBackup:=False ActiveWindow.Close box = MsgBox("Filterdaten gespeichert unter C:\Users\Ich\Documents\", vbInformation, _ _ "Info") 'eMail senden Dim objOutlook As Object Dim objMail As Object Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) With objMail .To = "fuchs@domain.de" 'aus Tabelle 2 Spalte B .Subject = "Suche1" 'Da sollte in der eMail "Fuchs" stehen, nicht "Suche1" .Body = "Siehe Anhang" .Attachments.Add "C:\Users\Ich\Documents\Fuchs.xlsx" 'Der String der Ablage _ sollte auch automatisch generiert werden aus Speicherort und Suche .Display End With 'Wechsel in Urdatei, entfiltern und speichern Windows("141219").Activate Range("A1").Select ActiveSheet.ShowAllData Exit Sub Else End If Next Else box = MsgBox("Bitte geben Sie ein Suchkriterium ein.", vbExclamation, "Achtung") End If box = MsgBox("Das Suchkriterium wurde nicht gefunden.", vbExclamation, "Achtung") End Sub

Danke erstmal, aber ich glaub, wir haben bissl aneinander vorbei geredet.
Tabelle 1 hat alle Daten (in der Realität etwa 10000 Zeilen), Tabelle 2 hat etwa 80 Suchbegriffe (diese gibt s in Spalte 1 der Tabelle 1 auch) und dazugehörige eMailadressen. Und weder die Suchbegriffe noch die eMailadressen mag ich manuell suchen ;-)
Das Makro soll folgendes tun:
1. Gehe in Tabelle 2 zum ersten Eintrag und filtere in Spalte 1 in Tabelle 1 nach diesem Begriff
2. kopiere diese gefilterte Tabelle in ein neues Exceldokument und speichere dieses unter dem Namen mit dem ersten Begriff ab
3. öffne eine eMail und hänge das Exceldokument mit dem Namen des ersten Suchbegriffs an, sende dieses an die Mailadresse, die in Tabelle 2 hinter dem ersten Suchbegriff steht; Betreff ist der Suchbegriff
4. Gehe wieder in Tabelle 2 zum zweiten Eintrag usw - das wiederholt sich so lange, bis der 80. Suchbegriff abgearbeitet wurde.
LG Tim

Sub DateiErstellenHerber() Dim Speicherort As String Dim zelle, spalte As Range Dim letzte As Long With ThisWorkbook.Worksheets(2) letzte = .Cells(.Rows.Count, 1).End(xlUp).Row Set spalte = .Range("A2:A" & letzte) End With Speicherort = "C:\Users\Ich\Documents\" For Each zelle In spalte Set finden = ThisWorkbook.Worksheets(2).Range("A:A").Find(what:=zelle.Text, lookat:= _ xlWhole, MatchCase:=True) If Not finden Is Nothing Then 'Filtern nach Zwergenk. und Kopieren ActiveSheet.Range("$A$1:$D$20").AutoFilter Field:=1, Criteria1:= _ finden Range("A1").CurrentRegion.Offset(0, 0).SpecialCells(xlCellTypeVisible).EntireRow. _ Copy MsgBox ("Daten kopiert.") ' Neue xlsx geöffnet und Daten eingefügt Workbooks.Add Range("A1").Select ActiveSheet.Paste 'Datei Speichern und Schliessen ActiveWorkbook.SaveAs Filename:=Speicherort & finden, FileFormat:= _ xlOpenXMLWorkbook, CreateBackup:=False ActiveWindow.Close box = MsgBox("Filterdaten gespeichert unter C:\Users\Ich\Documents\", vbInformation, _ "Info") 'eMail senden Dim objOutlook As Object Dim objMail As Object Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) With objMail .To = zelle.Offset(0, 1).Text .Subject = zelle.Text .Body = "Siehe Anhang" .Attachments.Add "C:\Users\Ich\Documents\" & zelle.Text & ".xlsx" .Display End With 'Wechsel in Urdatei, entfiltern und speichern Windows("Tim").Activate Range("A1").Select ActiveSheet.ShowAllData Else End If Next End Sub

Hallo Tim,
ich hatte nebenbei einen Fehler im Code:


Sub DateiErstellenHerber()
Dim Speicherort As String
Dim zelle, spalte As Range
Dim letzte As Long
With ThisWorkbook.Worksheets(2) 'Hiermit wird der Bereich festgelegt, in dem er Später das  _
Suchkriterium herausliest
letzte = .Cells(.Rows.Count, 1).End(xlUp).Row
Set spalte = .Range("A2:A" & letzte)
End With
Speicherort = "C:\Users\Ich\Documents\"
For Each zelle In spalte 'Hier wird jede Zelle im 2. Tabellenblatt durchgegangen und je  _
einmal als Suchkriterium festgelegt
Set finden = ThisWorkbook.Worksheets(1).Range("A:A").Find(what:=zelle.Text, lookat:= _
xlWhole, MatchCase:=True) 'Hier wird im 1. Tabellenblatt (da war auch der Fehler im vorherigen  _
Code) nachgeschaut, ob es das vorher festgelegte Suchkriterium gibt
If Not finden Is Nothing Then 'Wenn das Suchkriterium gefunden wurde, wird  _
untenstehendes ausgeführt
'Filtern nach Zwergenk. und Kopieren
ActiveSheet.Range("$A$1:$D$20").AutoFilter Field:=1, Criteria1:= _
finden
Range("A1").CurrentRegion.Offset(0, 0).SpecialCells(xlCellTypeVisible).EntireRow. _
Copy
MsgBox ("Daten kopiert.")
' Neue xlsx geöffnet und Daten eingefügt
Workbooks.Add
Range("A1").Select
ActiveSheet.Paste
'Datei Speichern und Schliessen
ActiveWorkbook.SaveAs Filename:=Speicherort & finden, FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
ActiveWindow.Close
box = MsgBox("Filterdaten gespeichert unter C:\Users\Ich\Documents\", vbInformation, _
_
"Info")
'eMail senden
Dim objOutlook As Object
Dim objMail As Object
Set objOutlook = CreateObject("Outlook.Application")
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = zelle.Offset(0, 1).Text 'ziehe die Mailadresse ein Kästchen rechts des  _
Suchkriteriums von Tabellenblatt 2
.Subject = zelle.Text 'ziehe das Suchkriterium von Tabellenblatt 2 (hier auch  _
dein Tiername)
.Body = "Siehe Anhang"
.Attachments.Add "C:\Users\Ich\Documents\" & zelle.Text & ".xlsx" 'Da der  _
Tiername aus Tabellenblatt 2 und der Name der Tatei späte identisch sind, kannst du hier den Namen aus dem Tabellenblatt 2 auslesen
.Display
End With
'Wechsel in Urdatei, entfiltern und speichern
Windows("Tim").Activate
Range("A1").Select
ActiveSheet.ShowAllData
Else
End If
Next
End Sub

Diesmal auch mit ein paar Kommentaren. Ich hoffe du verstehst es.
Welche Variablen meinst du?
Gruß Marc

Beliebteste Forumthreads (12 Monate)

Per Makro: Tabellenteile in neue .xlsx

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Per Makro: Tabellenteile in neue .xlsx

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread