Top-Themen

Aktuelle Themen (A bis Z)

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit

gelöst Makro für Excel-Suche

Mitglied: MikeS9

MikeS9 (Level 1) - Jetzt verbinden

22.02.2013 um 11:10 Uhr, 3008 Aufrufe, 11 Kommentare

Hallo miteinander

Ich habe folgendes Problem:

Auf meinem PC befindet sich ein Ordner mit mehreren Excel Dateien (momentan 3, Tendenz steigend). Ich möchte nun ein Makro erstellen, welches sich in einer neuen Exceldatei (in einem anderen Ordner) befindet. Bei einem klick auf das Makro möchte ich gerne einen Suchbegriff eingeben, welcher alle Dateien im angegeben Ordner nach diesem Begriff durchsucht und die ganze Zeile in die Datei mit dem Makro kopiert.

Bis jetzt habe ich folgenden Code:


Sub dateien_durchsuchen_Click()
Dim wort$, fs As FileSearch, i%, efz%, wsA As Worksheet, wb As Workbook, ws As Worksheet, _
erg As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False

On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Auswahl").Delete
Application.DisplayAlerts = True
ThisWorkbook.Worksheets.Add.Name = "Auswahl"
Set wsA = ActiveWorkbook.Worksheets(1)

wort = InputBox("Suchwort")
Set fs = Application.FileSearch
With fs
' .LookIn = "\\192.168...\HakC\exceldateien"
.LookIn = "C:\Daten\Excel\1Projekte\FileTransfer_Allgemein"
.Filename = "*.xls"
.SearchSubFolders = False
.Execute
wsA.Range("A1").Value = "<" & wort & "> wurde in folgenden Dateien gefunden:"
wsA.Rows(1).Font.Bold = True

wsA.Range("B1").Value = "Dateiname"
wsA.Range("C1").Value = "1.Fundzelle"
For i = 1 To .FoundFiles.Count
Workbooks.Open .FoundFiles(i)
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set erg = Cells.Find(What:=wort, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not erg Is Nothing Then
efz = wsA.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsA.Cells(efz, 1).Value = .FoundFiles(i)
wsA.Cells(efz, 2).Value = Dir(.FoundFiles(i))
wsA.Cells(efz, 3).Value = erg.Address
End If
wb.Close False
Next i
End With
wsA.Columns.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub


Dieser funktioniert wunderbar, jedoch sieht das Suchergebnis nicht so aus wie ich es gerne hätte.

Es wird nur angezeigt in welcher Tabelle der gesuchte Begriff vorhanden ist. Wie könnte man den Code erweitern damit er alle Zeilen mit dem gesuchten Begriff kopiert?

Hoffe meine Frage ist versändlich

Besten Dank für eure Hilfe

Liebe Grüsse Mike

Mitglied: colinardo
22.02.2013, aktualisiert um 11:48 Uhr
Hi Mike,
Dafür gibt es die Funktion .FindNext(x)
Denn die Suche hört nach der ersten Fundstelle auf. Du musst also so lange weitersuchen bis die FindNext-Methode keine Ergebnisse mehr liefert.

Die Struktur sieht so aus:
Set c = Cells.Find(.....) 
If Not c Is Nothing Then 
     firstAddress = c.Address 
     Do 
         'hier kommt der Code den du mit der Fund-Zeile machen willst 
         Set c = Cells.FindNext(c) 
     Loop While Not c Is Nothing And c.Address <> firstAddress 
End If
c ist hierbei ein Objekt des Typs Range

Hoffe das hilft Dir weiter

Grüße Uwe
Bitte warten ..
Mitglied: MikeS9
27.02.2013 um 08:09 Uhr
Hallo Uwe

Danke für deine Antwort. Wo genau muss ich diese Funktion in meinem Code einfügen, kenn mich nicht so aus mit Makros.
Gäbe es auch eine Möglichkeit, dass alle Ergebnisse mit nur einem Klick auf Suchen angezeigt werden? Könnte als Ergebnis auch die ganze Zeile in die neue Tabelle kopiert werden?

Vielen Dank

Gruss Mike
Bitte warten ..
Mitglied: colinardo
27.02.2013, aktualisiert um 11:55 Uhr
Hi Mike,
die Stelle an dem der Code implantiert werden muss ist folgende:
01.
.. 
02.
... 
03.
Set wb = ActiveWorkbook 
04.
Set ws = ActiveSheet 
05.
Set erg = Cells.Find(What:=wort, LookIn:=xlValues, LookAt:= _ 
06.
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False) 
07.
If Not erg Is Nothing Then 
08.
     firstAddress = erg.Address  
09.
     Do  
10.
         efz = wsA.Cells(Rows.Count, 1).End(xlUp).Row + 1 
11.
         wsA.Cells(efz, 1).Value = .FoundFiles(i) 
12.
         wsA.Cells(efz, 2).Value = Dir(.FoundFiles(i)) 
13.
         wsA.Cells(efz, 3).Value = erg.Address 
14.
         'Spalte 1 bis 5 der gefundenen Reihe ins neue Blatt in Spalte 4 kopieren 
15.
         Range(erg.cells(1,1),erg.Cells(1,5)).Copy destination:=wsA.Cells(efz,4) 
16.
         Set erg = Cells.FindNext(erg) 
17.
     Loop While Not erg Is Nothing And erg.Address <> firstAddress  
18.
End If 
19.
wb.Close False 
20.
... 
21.
..
Für das kopieren der ganzen Reihe musst du folgendes Beachten wenn du die Komplette Zeile also von Spalte A->unendlich kopieren willst kannst du folgenden Befehl nutzen:
BEACHTE aber folgendes: Die Zielzelle muss in einem Arbeitsblatt in der Spalte A liegen, da ansonsten z.B. bei einer Zielzelle "B1" der Platz am Ende der Zeile nicht mehr ausreichen würde um die ganze Zeile einzufügen.
erg.EntireRow.Copy destination:=[HIER DIE ZIELZELLE]
Für deinen Fall würde ich einen begrenzte Anzahl an Spalten kopieren(sie auch oben im Code):
Range(erg.cells(1,1),erg.Cells(1,5)).Copy destination:=wsA.Cells(efz,4)
Diese Zeile nimmt die ersten 5 Spalten und kopiert sie in deine neue Arbeitsmappe hinter deine 3 bisher gefüllten Spalten. Die Anzahl der Spalten kannst du ja nach deinem Gusto anpassen.

Hoffe das war soweit verständlich...

Grüße Uwe
Bitte warten ..
Mitglied: MikeS9
27.02.2013 um 11:52 Uhr
Hallo Uwe
Danke für die schnelle Antwort!

Habe nun folgendes Problem:

Ich habe die Datei mit dem Suchmakro auf dem Desktop. Die zu durchsuchenden Excel-Tabellen habe ich in einem eigenen Ordner. (Zum Testen habe ich extra eine kleine Excel-Tabelle genommen) Das Such-Makro habe ich mit folgdenem Code erstellt:


Sub dateien_durchsuchen_Click()
Dim wort$, fs As FileSearch, i%, efz%, wsA As Worksheet, wb As Workbook, ws As Worksheet, _
erg As Range
Application.DisplayAlerts = False
Application.ScreenUpdating = False

On Error Resume Next
Application.DisplayAlerts = False
ThisWorkbook.Worksheets("Auswahl").Delete
Application.DisplayAlerts = True
ThisWorkbook.Worksheets.Add.Name = "Auswahl"
Set wsA = ActiveWorkbook.Worksheets(1)

wort = InputBox("Suchwort")
Set fs = Application.FileSearch
With fs
' .LookIn = "\\192.168...\HakC\exceldateien"
.LookIn = "C:\...\...\..."
.Filename = "*.xls"
.SearchSubFolders = False
.Execute
wsA.Range("A1").Value = "<" & wort & "> wurde in folgenden Dateien gefunden:"
wsA.Rows(1).Font.Bold = True

wsA.Range("B1").Value = "Dateiname"
wsA.Range("C1").Value = "1.Fundzelle"
For i = 1 To .FoundFiles.Count
Workbooks.Open .FoundFiles(i)
Set wb = ActiveWorkbook
Set ws = ActiveSheet
Set erg = Cells.Find(What:=wort, LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not erg Is Nothing Then
firstAddress = c.Address
Do
efz = wsA.Cells(Rows.Count, 1).End(xlUp).Row + 1
wsA.Cells(efz, 1).Value = .FoundFiles(i)
wsA.Cells(efz, 2).Value = Dir(.FoundFiles(i))
wsA.Cells(efz, 3).Value = erg.Address
'Spalte 1 bis 5 der gefundenen Reihe ins neue Blatt in Spalte 4 kopieren
Range(erg.Cells(1, 1), erg.Cells(1, 2)).Copy Destination:=wsA.Cells(efz, 4)
Set erg = Cells.FindNext(erg)
Loop While Not erg Is Nothing And erg.Address <> firstAddress
End If
wb.Close False
Next i
End With
wsA.Columns.AutoFit
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub


Die Exceldatei (die die durchsucht wird) wird geöffnet. Leider passiert dann nichts mehr. Auch nach ca 5 Minuten nicht. Muss Excel dann mit dem Task-Manager beenden..

Was könnte da das Problem sein? Die Exceldatei hat nur 2 Datensätze (extra zum testen)

Danke im voraus!!
Bitte warten ..
Mitglied: colinardo
27.02.2013 um 11:55 Uhr
Sorry da ist mir ein kleiner Schreibfehler passiert:
firstAddress = c.Address
sollte so aussehen:
firstAddress = erg.Address
Bitte warten ..
Mitglied: MikeS9
28.02.2013 um 08:16 Uhr
Cool, super jetzt klappts! Vielen Dank! Jetzt habe ich nur noch ein kleines Problem. Ich möchte gerne, dass von jeder gefundenen Zeile die Spalten A-U kopiert werden.

Was muss ich da an meinem Code noch ändern?

Gruss Mike
Bitte warten ..
Mitglied: colinardo
28.02.2013, aktualisiert um 09:15 Uhr
01.
Range(erg.Cells(1, 1), erg.Cells(1, 21)).Copy Destination:=wsA.Cells(efz, 4)
8-)
Bitte warten ..
Mitglied: MikeS9
28.02.2013 um 08:56 Uhr
So wird aber erst von der Spalte an kopiert, wo sich der gesuchte Begriff befindet. Ich möchte gerne dass die ganze zeile von A-U kopiert wird.

Bitte warten ..
Mitglied: colinardo
28.02.2013 um 09:13 Uhr
Ach so, verstehe....

01.
Range(erg.EntireRow.cells(1,1), erg.EntireRow.cells(1, 21)).Copy Destination:=wsA.Cells(efz, 4)
Bitte warten ..
Mitglied: MikeS9
28.02.2013 um 09:23 Uhr
Jetzt hats geklappt. 1000 Dank!

Liebe Grüsse Mike
Bitte warten ..
Mitglied: colinardo
28.02.2013 um 09:24 Uhr
Keine Ursache, bitte noch den Beitrag als gelöst markieren.. Danke
Bitte warten ..
Ähnliche Inhalte
Microsoft Office
Excel Makro
Frage von maloh1984Microsoft Office4 Kommentare

Hallo Habe ein Problem, ein Kunde der hat Excellisten mit Makro die lassen sich öffnen aber die Buttons reagieren ...

Microsoft Office
Excel-Makro
gelöst Frage von yuki13Microsoft Office7 Kommentare

Hallo Zusammen!! :-) Ich bin nicht so fit in Excel Makros und wollte mich hier erkundigen, ob mir jemand ...

VB for Applications

Excel Makro zum Suchen von Spalten und exportieren in CSV

Frage von RaptoxVB for Applications3 Kommentare

Hallo Zusammen Ich bin nun seit längerem daran beschäftigt in Excel 2013 ein Makro zu basteln, welches folgendes erledigt: ...

Microsoft Office

Excel Makro: in Zeile suchen, Spalten ein- und ausblenden

gelöst Frage von Florian86Microsoft Office2 Kommentare

Hallo, ich möchte in der Datei, in Zeile eins nach der KW suchen und mir dann den Bereich von ...

Neue Wissensbeiträge
Windows 10

Neue Sicherheitslücke in Windows 10 (Version 1709) durch Google öffentlich geworden

Information von kgborn vor 8 StundenWindows 10

Vor ein paar Tagen haben Googles Sicherheitsforscher vom Projekt Zero eine Sicherheitslücke im Edge-Browser publiziert. Jetzt wurde eine weitere ...

iOS
IOS 11.2.6 verfügbar
Information von sabines vor 14 StundeniOS

Mit dem Update soll der Bug behoben werden, bei dem eine bestimmte Zeichenkette IOS zum Absturz gebracht hat.

Sicherheit
Sicherheitsrisiko: Die Krux mit 7-Zip
Information von kgborn vor 1 TagSicherheit8 Kommentare

Bei vielen Anwendern ist das Tool 7-Zip zum Entpacken von Archivdateien im Einsatz. Die Software ist kostenlos und steht ...

Internet

Datendealing im WWW Tracking Methoden immer brutaler

Information von sabines vor 1 TagInternet

Interessanter Artikel zum Thema Tracking im WWW und die immer "besseren" Methoden des Trackings. Professor Arvind Narayanan (Princeton-Universität) betreibt ...

Heiß diskutierte Inhalte
Router & Routing
LANCOM VPN CLIENT einrichten
Frage von Finchen961988Router & Routing27 Kommentare

Hallo, ich habe ein Problem und hoffe ihr könnt mir helfen, wir haben einen Kunden der hat einen Speedport ...

Windows Server
AD DS findet Domäne nicht, behebbar?
Frage von schapitzWindows Server25 Kommentare

Guten Tag, ich habe bei einem Kunden ein Problem mit den AD DS. Umgebung ist folgende: Windows Server 2016 ...

LAN, WAN, Wireless
VPN Cisco ASA5505 PaloAlto PA-200
gelöst Frage von YannoschLAN, WAN, Wireless22 Kommentare

Hallo zusammen, ich würde gerne ein Site-to-Site VPN zwischen den beiden Standorten aufbauen. PaloAlto PA200 Internetanschluss Deutsche Telekom GK ...

Visual Studio
Singletone Objekt in Datei speichern
gelöst Frage von it4baerVisual Studio13 Kommentare

Hallo, ist es möglich ein Singleton-Objekt zu "serialisieren" und dann in eine Datei zu speichern um es später wieder ...