Herbers Excel/VBA-Archiv
Problem mit "Weitersuchen"
- Problem mit "Weitersuchen" von Ahrens vom 28.09.2020 12:36:43
- AW: Problem mit "Weitersuchen" - von Nepumuk am 28.09.2020 12:59:42
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 13:49:42
- AW: Problem mit "Weitersuchen" - von Nepumuk am 28.09.2020 13:57:50
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 14:26:50
- AW: Problem mit "Weitersuchen" - von Nepumuk am 28.09.2020 14:59:39
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 15:38:29
- AW: Problem mit "Weitersuchen" - von Nepumuk am 28.09.2020 15:50:26
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 16:37:38
- AW: Problem mit "Weitersuchen" - von Nepumuk am 28.09.2020 16:46:19
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 17:02:37
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 17:02:37
- AW: Problem mit "Weitersuchen" - von Nepumuk am 28.09.2020 16:46:19
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 16:37:38
- AW: Problem mit "Weitersuchen" - von Nepumuk am 28.09.2020 15:50:26
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 16:20:37
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 15:38:29
- AW: Problem mit "Weitersuchen" - von Nepumuk am 28.09.2020 14:59:39
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 14:26:50
- AW: Problem mit "Weitersuchen" - von Nepumuk am 28.09.2020 13:57:50
- AW: Problem mit "Weitersuchen" - von Ahrens am 28.09.2020 13:49:42
Geschrieben am: 28.09.2020 12:36:43
Hallo,
ich bin neu hier und habe nur bedingt Kennznisse von VBA.
Aus diesem Grund hoffe ich bei Euch hilfe zu bekommen.
Ich habe schon aus einem etwas älteren Eintrag bei Euch ein Excel mit einem "fast"
passenden Makro gefunden und konnte es auch ein wenig auf meine Problemstellung anpassen.
Meine Problemstellung ist folgende:
ich habe mehrere XLSX Dateien. Diese Dateien beinhalten Daten von unterschiedlichen Jahrgängen.
Wenn ich jetzt alle diese Dateien in einer Schleife nach einem definierten String durchsuche, läuft meine
Suche auch. Es werden alle Dateien durchsucht und die Daten sauber in einem extra Tabellen Blatt abgelegt.
Leider funktioniert die Suche aber nur begrenzt. Es wird bei der Suche nur der erste erkannte Begriff
als richtiges Ergebniss gefunden und auf der Ergebniss Seite abgelegt.
Die Suche wird nach dem ersten positiven Treffer in der Tabelle beendet und auf den nächsten Tabelle fortgesetzt.
Ich weiss schon, dass hier ein .FindNext die Lösung bringen sollt, nur leider erhalte ich, egal wie und wo ich es einbaue
den Kompilierungsfehler, dass die Methode oder das datenobjekt nicht gefunden wird.
Ich hoffe Ihr könnt mir helfe. Ich stelle Euch die xmlm zur Verfügung.
https://www.herber.de/bbs/user/140487.xlsm
Vielen Dank im Voraus
MfG
Frank
von: Nepumuk
Geschrieben am: 28.09.2020 12:59:42
Hallo Frank,
teste mal:
Dim rng As Range
Dim tbl As Worksheet
Dim wb As Workbook
Dim strFirsAddress As String
'Datei schreibgeschützt öffnen
Set wb = Workbooks.Open(Filename:=strDateiName, ReadOnly:=True, UpdateLinks:=0)
Application.StatusBar = "Bearbeite Datei """ & strDateiName & """"
'Alle Tabellenblätter in Mappe abarbeiten
For Each tbl In wb.Worksheets
With tbl
'Suchbegriff suchen
'Set rng = .Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, lookat:=xlWhole)
'Set rng = .Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, lookat:=xlPart)
', SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
'Set rng = .Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, lookat:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=True)
Set rng = .UsedRange.Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, lookat:=xlPart)
If Not rng Is Nothing Then
bolGefunden = True
strFirsAddress = rng.Address
Do
'Nächste frei zeile im Ergebnisblatt
lngZeile_E = fncNextFreeRow(wks:=wksErg)
If lngZeile_E > 3 Then
lngZeile_E = lngZeile_E + 1
End If
'Daten in Zeile 1 kopieren - Formate und Werte
.Range(.Cells(5, 1), .Cells(5, 130)).Copy
With wksErg
'.Cells(lngZeile_E, 4).PasteSpecial Paste:=xlPasteFormats
.Cells(lngZeile_E, 4).PasteSpecial Paste:=xlPasteValues
.Cells(lngZeile_E, 1).Value = varSuchen
.Cells(lngZeile_E, 2).Value = wb.Name
.Cells(lngZeile_E + 1, 2).Value = tbl.Name
End With
'Daten in gefundener Zeile kopieren - Formate und Werte
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 130)).Copy
With wksErg.Cells(lngZeile_E + 1, 4)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With
Set rng = .UsedRange.FindNext(After:=rng)
Loop Until rng.Address = strFirsAddress
End If
End With
Application.CutCopyMode = False
Next tbl
'Datei ohne Speichern schließen
wb.Close savechanges:=False
Application.StatusBar = False
End Sub
Gruß
Nepumuk
von: Ahrens
Geschrieben am: 28.09.2020 13:49:42
Hallo Nepumuk,
Danke für die schnelle Antwort.
Leider brachte die Änderung nicht den Erfolg.
Wenn ich diese SUB gegen die bestehende austausche werden alle Einrtäge angezeigt, auch denn der SuchString/Teilstring nicht in einem Der Zellen steht. Auch werden Einträge mehrfach angezeigt. Die suche über eine Datei mit 11 Tabellen a 25 Datensätze bring jetzt über 1500 Ergebnisse.
MfG
Frank
von: Nepumuk
Geschrieben am: 28.09.2020 13:57:50
Hallo Frank,
lade mal eine Testmappe hoch die durchsucht werden soll.
Gruß
Nepumuk
von: Ahrens
Geschrieben am: 28.09.2020 14:26:50
Hallo Nepumuk,
Hier die Test Mappe.
Als Such-String könnte "AOK" oder "AOK Plus" verwendet werden.
Wenn ich mit meiner "originalen" Suche nach dem String Suche erhalte ich von jeder Tabelle je nur ein Ergebnis (auch wenn mehrere gültige vorhanden sind). Wenn ich das Makro "übernehme" und das SUB austausche, liege ich bei dieser Test-Datei bei 715 Einträge. Wobei auch falsche "Treffer" sind
https://www.herber.de/bbs/user/140492.xlsx
Gruß
Frank
von: Nepumuk
Geschrieben am: 28.09.2020 14:59:39
Hallo Frank,
deine Suche nach der nächsten freien Zeile hat die Suche zerschossen. Teste mal damit:
Dim rng As Range
Dim tbl As Worksheet
Dim wb As Workbook
Dim strFirsAddress As String
'Datei schreibgeschützt öffnen
Set wb = Workbooks.Open(Filename:=strDateiName, ReadOnly:=True, UpdateLinks:=0)
Application.StatusBar = "Bearbeite Datei """ & strDateiName & """"
'Alle Tabellenblätter in Mappe abarbeiten
For Each tbl In wb.Worksheets
'Nächste frei zeile im Ergebnisblatt
lngZeile_E = fncNextFreeRow(wks:=wksErg)
If lngZeile_E > 3 Then
lngZeile_E = lngZeile_E + 1
End If
With tbl
'Suchbegriff suchen
'Set rng = .Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, lookat:=xlWhole)
'Set rng = .Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, lookat:=xlPart)
', SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
'Set rng = .Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, lookat:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=True)
Set rng = .UsedRange.Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlPart)
If Not rng Is Nothing Then
bolGefunden = True
strFirsAddress = rng.Address
'Daten in Zeile 1 kopieren - Formate und Werte
.Range(.Cells(5, 1), .Cells(5, 130)).Copy
Do
With wksErg
'.Cells(lngZeile_E, 4).PasteSpecial Paste:=xlPasteFormats
.Cells(lngZeile_E, 4).PasteSpecial Paste:=xlPasteValues
.Cells(lngZeile_E, 1).Value = varSuchen
.Cells(lngZeile_E, 2).Value = wb.Name
.Cells(lngZeile_E + 1, 2).Value = tbl.Name
End With
'Daten in gefundener Zeile kopieren - Formate und Werte
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 130)).Copy
With wksErg.Cells(lngZeile_E + 1, 4)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With
lngZeile_E = lngZeile_E + 1
Set rng = .UsedRange.FindNext(After:=rng)
Loop Until rng.Address = strFirsAddress
End If
End With
Application.CutCopyMode = False
Next tbl
'Datei ohne Speichern schließen
wb.Close savechanges:=False
Application.StatusBar = False
End Sub
Gruß
Nepumuk
von: Ahrens
Geschrieben am: 28.09.2020 15:38:29
Hallo Nepumuk,
Danke für Deine schnelle Reaktion.
Das sieht sehr gut aus und funktioniert auch "fast" so wie ich es mir wünsche.
Schön wäe jetzt noch, wenn in der Spalte B bei den Suchergebnissen immer vor dem Treffer der Name des Tabellen Blattes steht. Irgendwie überschreibt der bei mir immer die Tagellen-Blatt-Bezeichnung durch den dateinamen und schreibt nur vor dem letzten Treffer den Namen des Tabellen-Blattes.
Danke im Voraus.
Gruß
Frank
von: Nepumuk
Geschrieben am: 28.09.2020 15:50:26
Hallo Frank,
so besser?
Dim rng As Range
Dim tbl As Worksheet
Dim wb As Workbook
Dim strFirsAddress As String
'Datei schreibgeschützt öffnen
Set wb = Workbooks.Open(Filename:=strDateiName, ReadOnly:=True, UpdateLinks:=0)
Application.StatusBar = "Bearbeite Datei """ & strDateiName & """"
'Alle Tabellenblätter in Mappe abarbeiten
For Each tbl In wb.Worksheets
'Nächste frei zeile im Ergebnisblatt
lngZeile_E = fncNextFreeRow(wks:=wksErg)
If lngZeile_E > 3 Then
lngZeile_E = lngZeile_E + 1
End If
With tbl
'Suchbegriff suchen
'Set rng = .Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, lookat:=xlWhole)
'Set rng = .Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, lookat:=xlPart)
', SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
'Set rng = .Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, lookat:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, SearchFormat:=True)
Set rng = .UsedRange.Find(What:=varSuchen, After:=.Range("A1"), LookIn:=xlValues, LookAt:=xlPart)
If Not rng Is Nothing Then
bolGefunden = True
strFirsAddress = rng.Address
'Daten in Zeile 1 kopieren - Formate und Werte
.Range(.Cells(5, 1), .Cells(5, 130)).Copy
With wksErg
'.Cells(lngZeile_E, 4).PasteSpecial Paste:=xlPasteFormats
.Cells(lngZeile_E, 4).PasteSpecial Paste:=xlPasteValues
.Cells(lngZeile_E, 1).Value = varSuchen
.Cells(lngZeile_E, 2).Value = wb.Name
.Cells(lngZeile_E + 1, 2).Value = tbl.Name
End With
Do
'Daten in gefundener Zeile kopieren - Formate und Werte
.Range(.Cells(rng.Row, 1), .Cells(rng.Row, 130)).Copy
With wksErg.Cells(lngZeile_E + 1, 4)
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With
lngZeile_E = lngZeile_E + 1
Set rng = .UsedRange.FindNext(After:=rng)
Loop Until rng.Address = strFirsAddress
End If
End With
Application.CutCopyMode = False
Next tbl
'Datei ohne Speichern schließen
wb.Close savechanges:=False
Application.StatusBar = False
End Sub
Gruß
Nepumuk
von: Ahrens
Geschrieben am: 28.09.2020 16:37:38
Hallo Nepumuk,
Da sieht sehr, seht gut aus. So schön kann Excel sein.
Wenn man wie Du Ahnung hat, aber deswegen binn ich mir ja nich zu Schade Spezialisten zu fragen.
Das Ergebnis ist so wie ich mir da vorgestellt habe.
Vielleicht könntest du mir aber noch einen Tipp geben, wie ich bei der Suche die Spalte "E" (5. Spalte) in den zu durchsuchenden Excel-Arbeitsmappen (deren Excel-Tabellen ausschliesen kann?
In dem Feld steht die Mail-Adresse und die hat oft den Normalen oder den Firmennamen im Inhalt.
Da die Suche aber über "LookAt:=xlPart" läuft, wird der Teilstring eventuell in einer Zeile mehrfach gefunden. Somit sind dann eventuell mehrer Treffer in einer Zeile möglich. Oder aber was eventuell auch eine Möglichkeit wäre dass man die Suche auf die esrten 4 Spalten begrenzt.
Nur wie setzt man dass um?
Gruß
Frank
von: Nepumuk
Geschrieben am: 28.09.2020 16:46:19
Hallo Frank,
so:
Set rng = .Columns("A:D").Find(....
Set rng = .Columns("A:D").FindNext(After:=rng)
Gruß
Nepumuk
von: Ahrens
Geschrieben am: 28.09.2020 17:02:37
Hallo Nepumuk,
Danke das ist genau die Lösung.
Das Ergebnis ist jetzt genau so, wie ich es mir vorgestellt habe.
Du hast mir meinen Abend gerettet.
;-)
Also nochmals ein grosses DANKE für die schnelle Hilfe
Gruß und schönen Abend noch.
Frank
von: Ahrens
Geschrieben am: 28.09.2020 16:20:37
Hallo Nepumuk,
Danke für Deine schnelle Reaktion.
Das sieht sehr gut aus und funktioniert auch "fast" so wie ich es mir wünsche.
Schön wäe jetzt noch, wenn in der Spalte B bei den Suchergebnissen immer vor dem Treffer der Name des Tabellen Blattes steht. Irgendwie überschreibt der bei mir immer die Tagellen-Blatt-Bezeichnung durch den dateinamen und schreibt nur vor dem letzten Treffer den Namen des Tabellen-Blattes.
Danke im Voraus.
Gruß
Frank