Microsoft Excel

Herbers Excel/VBA-Archiv

Suchen und auflisten

Betrifft: Suchen und auflisten von: Gregor
Geschrieben am: 19.11.2014 17:03:37

Hallo zusammen

Ich will in einem Bereich auf Blatt Muster1 nach einem Suchbegriff suchen und die Spalte 1 und _ 2 der Zeile des gefundenen Suchbegriffes in Blatt Muster2 in die Zeile des Suchbegriffs übertragen. Die Suchbefriffe können mehrmals vorkommen. Dazu habe ich folgenden Code geschrieben:

Sub Suchen_und_auflisten()
    Dim Bereich As Range
    Dim rng As Range
    Dim sFind As String
    Worksheets("Muster1").Activate
    Set Bereich = Worksheets("Muster1").Range(Cells(3, 78), Cells(129, 125))
    IntLastRow = Worksheets("Muster2").Cells(Rows.Count, 1).End(xlUp).Row
    For Start = 2 To IntLastRow
        sFind = Worksheets("Muster2").Cells(Start, 1)
        Spalte = 31
        For Each rng In Bereich
            If InStr(rng, sFind) Then
                Worksheets("Muster2").Cells(Start, Spalte) = Worksheets("Muster1").Cells(rng. _
Row, 2)
                Worksheets("Muster2").Cells(Start, Spalte + 1) = Worksheets("Muster1").Cells( _
rng.Row, 1)
                Spalte = Spalte + 2
            End If
        Next
    Next Start
End Sub

Soweit so gut, nur geht das etwas lange und zudem will ich doppelte Einträge (Überträge) aus Blatt Muster1 nur einmal in Blatt Muster2 übertagen. Vermutlich geht das schneller mit arrDaten(). Und wie kann ich doppelte Überträge vermeiden?

Vielen Dank und Gruss
Gregor

  

Betrifft: mit Find(...) von: Tino
Geschrieben am: 19.11.2014 19:28:56

Hallo,
musst du wirklich alle Zellen im Bereich BZ3:DU129 (6096 Zellen) durchsuchen?
Doppelte werden nicht übertragen, weil schon nach dem ersten Treffer die nächste Zeile dran kommt.
(wenn ich es richtig verstanden habe!)

Versuch mal vielleicht geht es so.


Sub Suchen_und_auflisten()
Dim Bereich As Range
Dim rng As Range
Dim sFind As String, IntLastRow&, Start&, Spalte&

With Worksheets("Muster1")
    Set Bereich = .Range(.Cells(3, 78), .Cells(129, 125))
End With

With Worksheets("Muster2")
    IntLastRow = .Cells(Rows.Count, 1).End(xlUp).Row
    
    Spalte = 31
    
    For Start = 2 To IntLastRow
        sFind = .Cells(Start, 1)
        
        Set rng = Bereich.Find(sFind, LookIn:=xlValues, LookAt:=xlPart, _
                    SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=False, SearchFormat:=False)
                    
        If Not rng Is Nothing Then
            .Cells(Start, Spalte) = Worksheets("Muster1").Cells(rng.Row, 2)
            .Cells(Start, Spalte + 1) = Worksheets("Muster1").Cells(rng.Row, 1)
        End If
    
    Next Start
End With

End Sub
Gruß Tino


  

Betrifft: AW: mit Find(...) von: Gregor
Geschrieben am: 20.11.2014 09:01:55

Hallo Tino

Danke für deinen Code.
Es müssen aber alle Zellen durchsucht werden. Grudsätzlich ergibt mein Code das richtige Ergebnis, nur dass er langsam ist weshalb ich dachte, mit der arr()-Funktion würde das schneller gehen, da nur einmal pro Zeile kopiert würde (kriege den arr()-Code aber nicht hin.
Für das eliminieren der doppelten Begriffe habe ich im Forum eine neur Frage gestellt.

Danke und Gruss
Gregor


  

Betrifft: AW: mit Find(...) von: Tino
Geschrieben am: 20.11.2014 14:59:24

Hallo,
lade mal ein Bsp. Hoch.
Dann kann man bestimmt was einbauen .

Gruß Tino


 

Beiträge aus den Excel-Beispielen zum Thema "Suchen und auflisten"