Microsoft Excel

Herbers Excel/VBA-Archiv

Problem mit "Weitersuchen"

Betrifft: Problem mit "Weitersuchen" von: Ahrens
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

Betrifft: AW: Problem mit "Weitersuchen"
von: Nepumuk
Geschrieben am: 28.09.2020 12:59:42

Hallo Frank,

teste mal:

Sub prcAktion(ByVal strDateiName As String)
    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

Betrifft: AW: Problem mit "Weitersuchen"
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

Betrifft: AW: Problem mit "Weitersuchen"
von: Nepumuk
Geschrieben am: 28.09.2020 13:57:50

Hallo Frank,

lade mal eine Testmappe hoch die durchsucht werden soll.

Gruß
Nepumuk

Betrifft: AW: Problem mit "Weitersuchen"
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

Betrifft: AW: Problem mit "Weitersuchen"
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:

Sub prcAktion(ByVal strDateiName As String)
    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

Betrifft: AW: Problem mit "Weitersuchen"
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

Betrifft: AW: Problem mit "Weitersuchen"
von: Nepumuk
Geschrieben am: 28.09.2020 15:50:26

Hallo Frank,

so besser?

Sub prcAktion(ByVal strDateiName As String)
    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

Betrifft: AW: Problem mit "Weitersuchen"
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

Betrifft: AW: Problem mit "Weitersuchen"
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

Betrifft: AW: Problem mit "Weitersuchen"
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

Betrifft: AW: Problem mit "Weitersuchen"
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