Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
440to444
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
440to444
440to444
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

automatisiertes Suchen/Kopieren???

automatisiertes Suchen/Kopieren?
16.06.2004 10:51:25
Stefan
Hallo zusammen,
ich habe folgendes Problem:
Ich muß aus einer sehr umfangreichen Arbeitsmappe mit ca. 13 Blättern, die jeweils ca. 800 Zeilen und 15 Spalten haben alle Teile mit einem bestimmten Attribut heraussuchen und in eine neue Arbeitsmappe einfügen.
Wie muß so ein Makro aussehen, das alle Blätter nach einem bestimmten Attribut durchsucht und dann die kompletten betreffenden Zeile die das Attribut enthalten in die neue Arbeitsmappe kopiert. Ist soetwas überhaupt möglich?
Um das ganze dann auch noch auszureizen, gibt es in einem 2. Schritt auch die Möglichkeit, einem Makro beizubringen das gleiche wie oben angesprochen zu machen. Aber nicht nur in einer einzigen Mappe, sondern in einem ganzen Ordner mit ca. 50 Mappen.......
Schöne Grüße
Stefan

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: automatisiertes Suchen/Kopieren?
Marcl
Hallo,
mit diesem Makro kannst Du eine neue Datei unter eigenem Namen anlegen und in der Originaldatei den Suchbegriff wählen.
Deine Zeilen werden komplett kopiert und in der Zieldatei eingefügt.
In der Originaldatei gelöscht, aber wenn man sie schließt ohne zu speichern, bleibt sie unverändert.
Wie ist das mit den 50 anderen Dateien?
Gruß
Marcl

Sub suchen()
Quelldatei = ActiveWorkbook.Name
Workbooks.Add
'Neue Mappe speichern unter "Z:\.......xls"
datei = InputBox("Name der Datei?")
ActiveWorkbook.SaveAs Filename:="C:\Eigene Dateien\" & datei & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Zieldatei = ActiveWorkbook.Name
Windows(Quelldatei).Activate
On Error GoTo errorhandler
such = InputBox("Bitte den Suchbegriff eingeben")
Dim i%
' Schleife von Zelle 1 bis 21000
For i = 1 To 21000
' In Spalte A suchen
Columns("A:A").Select
' suchen lassen
Selection.Find(What:=such, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
' Zeile kopieren und in Tabälle alle Werte einfügen
Rows(ActiveCell.Row).Copy
Windows(Zieldatei).Activate
Rows(ActiveCell.Row).Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
' Zelle in Originaltabelle löschen, um Doppeleintragungen zu vermeiden
Windows(Quelldatei).Activate
Rows(ActiveCell.Row).Delete
Next i
Exit Sub
errorhandler:
Windows(Zieldatei).Activate
Windows(Quelldatei).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
MsgBox ("Fertig! Keine weiteren Übereinstimmungen mehr zu finden!")
End Sub

Anzeige
AW: automatisiertes Suchen/Kopieren?
17.06.2004 06:55:32
Stefan
Hallo Marcl,
erst mal vielen Dank für Deine Hilfe.
Beim ersten Mal hat's Super funktioniert. Aber nun bleibts immer hängen an der Stelle:
Windows(Quelldatei).Activate
Wo liegt denn mein Fehler?
Nun noch zum 2. Problem:
Ich hatte mir vorgestellt eine neue leere Arbeitsmappe zu öffnen, dann ein Makro auszuführen, dass abfragt in welchem Pfad die 50 Dateien stehen. Dann öffnet das Makro die 50 Dateien nacheinander sucht nach dem Begriff und trägts in meine geöffnete Mappe ein. Die 50 Dateien stehen aber auch teilweise in Unterordnern :-(((( Ist das überhaupt umsetzbar?
Gruß
Stefan
Anzeige
AW: automatisiertes Suchen/Kopieren?
Marcl
Windows(Quelldatei).Activate kehrt zur Originaldatei zurück
Ganz oben steht Quelldatei = ActiveWorkbook.Name
Das Makro muss immer in der Original(Quell)datei stehen und merkt sich den Namen der Datei.
So springt es immer zwischen der Quell- und Zieldatei, um die Daten zu kopieren
Wie sind die anderen Datein benannt?
Wenn sie auch in Unterordnern stehen, wird es schwierig.
Gruß Marcl
AW: automatisiertes Suchen/Kopieren?
Marcl
Noch eine kleine Eergänzung:
schreibe mal direkt zwischen Dim i% und
' Schleife von Zelle 1 bis 21000
folgendes:
Dim Sh As Worksheet
For Each Sh In Worksheets
Sh.Activate
und zwischen Next i und Exit Sub
Next Sh
Auf diese Weise kann man wenigstens alle Blätter der Datei durchsuchen.
Gruß Marcl
Anzeige
Falscher Code! Hier der neue
Marcl
Irgendwie habe ich Mist gemacht:
hier der Neue Code, um in allen Blättern der Datei nach dem Begriff zu suchen.

Sub suchen()
Quelldatei = ActiveWorkbook.Name
Workbooks.Add
'Neue Mappe speichern unter "Z:\.......xls"
datei = InputBox("Name der Datei?")
ActiveWorkbook.SaveAs Filename:="C:\Eigene Dateien\" & datei & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Zieldatei = ActiveWorkbook.Name
Windows(Quelldatei).Activate
such = InputBox("Bitte den Suchbegriff eingeben")
Dim i%
' suchen lassen
Dim Sh As Worksheet
Dim GZelle As Range
Dim FStelle$
For Each Sh In Worksheets
Sh.Activate
' In Spalte A suchen
Columns("A:A").Select
Selection.Find(What:=such, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Do
' Zeile kopieren und in neuer Datei alle Werte einfügen
Rows(ActiveCell.Row).Copy
Windows(Zieldatei).Activate
Rows(ActiveCell.Row).Select
ActiveSheet.Paste
ActiveCell.Offset(1, 0).Select
' Zelle in Originaltabelle löschen, um Doppeleintragungen zu vermeiden
Windows(Quelldatei).Activate
Rows(ActiveCell.Row).Delete
On Error GoTo err
err:
Exit Do
Loop
' nächstes Blatt auswählen
Next Sh
' wenn keine Übereinstimmung mehr zu finden ist
Windows(Zieldatei).Activate
Windows(Quelldatei).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
MsgBox ("Fertig! Keine weiteren Übereinstimmungen in dieser Datei mehr zu finden!")
End Sub

Anzeige
AW: Falscher Code! Hier der neue
18.06.2004 11:02:27
StefanA
Hallo Marcl,
es bleibt leider immer noch an der gleichen Stelle hängen.
Gruß
Stefan

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige