Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Per Makro: Tabellenteile in neue .xlsx

Betrifft: Per Makro: Tabellenteile in neue .xlsx von: Tim
Geschrieben am: 01.11.2020 00:11:05

Hallo zusammen,

ich habe eine Datei mit ca. 10000 Zeilen in Tabelle 1.
In Tabelle 2 stehen in den Zellen A2:A80 (später sicher auch mal mehr - drum wäre es gut, die Schleife nach der letzten Zelle mit Inhalt zu beenden) Daten, die die Grundlage für das Filtern nach und erzeugen einer neuen Datei mit selbigem Namen sind
In den Zellen B2:B80 stehen die email-Adressen, an die die eben generierten Dateien verschickt werden sollen.
Für eine Handvoll Datensätze meiner Testdatei ist das kein Problem, das Makro steht, da such ich einfach nach 5 verschiedenen Begriffen ("Suche1-5"). Aber das machts bei 80 Begriffen unsäglich lang und unübersichtlich.

Nur wie bekomm ich das hin, dass das Makro in Tabelle 2 nach dem Datensatz sucht, diesen bearbeitet und dann beim nächsten weitermacht?

---

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

Hat jemand eine tolle Idee dazu?

Vielen Dank & Beste Grüße
Tim


Betrifft: AW: Per Makro: Tabellenteile in neue .xlsx
von: Marc
Geschrieben am: 01.11.2020 00:56:38

Hallo Tim,

hast du eine Testdatei für mich? Ich habe eine Möglichkeit im Kopf.

Gruß Marc

Betrifft: AW: Per Makro: Tabellenteile in neue .xlsx
von: Tim
Geschrieben am: 01.11.2020 11:13:19

Hallo Marc,

hier ist die Testdatei:

https://www.herber.de/bbs/user/141219.xlsm

Es gibt noch ein paar Anmerkungen im Makro.


Besten Dank!

Betrifft: AW: Per Makro: Tabellenteile in neue .xlsx
von: Marc
Geschrieben am: 01.11.2020 14:07:39

Hallo Tim,

ich habe dir jetzt mal folgendes zusammengestellt, damit kannst du etwas schneller und unabhängiger vom Code suchen:
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

Was ich jetzt noch nicht verstanden habe, ist wohin du die Mailadresse in der neu erstellten Exceltabelle haben möchtest.

Reicht es dir aus das ganze einmalig in die neue Tabelle einzufügen, oder soll bei jedem einzelnen Datensatz die ein und selbe Mailadresse hinten dran stehen?

Gruß Marc

Betrifft: AW: Per Makro: Tabellenteile in neue .xlsx
von: Tim
Geschrieben am: 01.11.2020 15:57:26

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

Betrifft: AW: Per Makro: Tabellenteile in neue .xlsx
von: Marc
Geschrieben am: 01.11.2020 21:40:52

Hallo Tim,

hier der Code dafür. Ich hoffe du hast das so gemeint :)
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
Outlook ist ungetestet, sollte aber klappen.

Gruß Marc

Betrifft: CP MSO
von: ralf_b
Geschrieben am: 02.11.2020 08:46:57

https://www.ms-office-forum.net/forum/showthread.php?t=370845

Betrifft: AW: Per Makro: Tabellenteile in neue .xlsx
von: Tim
Geschrieben am: 02.11.2020 21:15:50

Hallo Marc, vielen Dank für deine Hilfe, das Makro läuft prima.

Das meiste kann ich nachvollziehen, trotzdem sind da noch 2 Fragen offen:
Woher nimmst du die Variable/den Begriff ? Ist der VBA-seitig vorgegeben und als solche definiert?
Und ist mir irgendwie auch schleierhaft? Was genau macht das?


Betse Grüße
Tim

Betrifft: AW: Per Makro: Tabellenteile in neue .xlsx
von: Marc
Geschrieben am: 03.11.2020 16:40:53

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