Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

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

Frage Microsoft Microsoft Office

Mitglied: MikeS9

MikeS9 (Level 1) - Jetzt verbinden

22.02.2013 um 11:10 Uhr, 2936 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 ..
Neuester Wissensbeitrag
Internet

Unbemerkt - Telekom Netzumschaltung! - BNG - Broadband Network Gateway

(3)

Erfahrungsbericht von ashnod zum Thema Internet ...

Ähnliche Inhalte
Heiß diskutierte Inhalte
Windows Server
Outlook Verbindungsversuch mit Exchange (15)

Frage von xbast1x zum Thema Windows Server ...

Microsoft Office
Keine Updates für Office 2016 (12)

Frage von Motte990 zum Thema Microsoft Office ...

Grafikkarten & Monitore
Tonprobleme bei Fernseher mit angeschlossenem Laptop über HDMI (11)

Frage von Y3shix zum Thema Grafikkarten & Monitore ...