Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Schnellerer Code Suchen und Kopieren

Betrifft: Schnellerer Code Suchen und Kopieren von: Werner
Geschrieben am: 31.10.2014 21:47:03

Hallo Helfer,

gibt es für diesen Code (Schleife) eine schnellere Alternative. Der Datenbestand der durchsucht werden soll ist riesig.

Sub LG_suchen()
        Dim rngAct As Range
        Dim strFindFirst As String
        Dim intLoopCount As Integer
        Dim varFind As Variant
        Dim i As Long
        i = 1
        'Begrenzung des zu durchsuchenden Bereichs
        With Worksheets("Tabelle1").Columns(6)
            '1. Übereinstimmung finden
            Set varFind = .Find(What:="Aktuell", After:=Range("F1"), _
                LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, _
                SearchDirection:=xlNext, MatchCase:=False)
            If Not varFind Is Nothing Then
                '1. Zelle für das Beenden der Do-Loop-Schleife merken
                strFindFirst = varFind.Address
                Do
                    'Treffer hochzählen
                    intLoopCount = intLoopCount + 1
                    'Zelle mit Suchkriterium in Tabelle2 kopieren
                    Range(varFind.Address).EntireRow.Copy Destination:=Worksheets("Tabelle2"). _
Cells(i, 1)
                    i = i + 1
                    'nächste Zelle suchen
                    Set varFind = .FindNext(varFind)
                'Schleife ausführen, solange das Suchkriterium gefunden
                'wird und bis letztendlich wieder die 1. Zelle erreicht ist
                '(sonst würde es in einer Endlosschleife enden)
                Loop While Not varFind Is Nothing And varFind.Address <> strFindFirst
            End If
        End With
        MsgBox intLoopCount
    End Sub

Danke für die Hilfe.

Gruß Werner

  

Betrifft: AW: Schnellerer Code Suchen und Kopieren von: Crazy Tom
Geschrieben am: 31.10.2014 22:08:52

Hallo Werner

ungetestet

Option Explicit

Sub LG_suchen()
    Dim rngAct As Range
    Dim strFindFirst As String
    Dim intLoopCount As Integer
    Dim varFind As Variant
    Dim i As Long
    i = 1
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
    'Begrenzung des zu durchsuchenden Bereichs
    With Worksheets("Tabelle1").Columns(6)
        '1. Übereinstimmung finden
        Set varFind = .Find(What:="Aktuell", LookIn:=xlFormulas, LookAt:=xlPart)
        If Not varFind Is Nothing Then
        '1. Zelle für das Beenden der Do-Loop-Schleife merken
        strFindFirst = varFind.Address
        Do
            'Treffer hochzählen
            intLoopCount = intLoopCount + 1
            'Zelle mit Suchkriterium in Tabelle2 kopieren
            Range(varFind.Address).EntireRow.Copy
            Worksheets("Tabelle2").Cells(i, 1).PasteSpecial xlPasteValues
            i = i + 1
            'nächste Zelle suchen
        Set varFind = .FindNext(varFind)
        'Schleife ausführen, solange das Suchkriterium gefunden
        'wird und bis letztendlich wieder die 1. Zelle erreicht ist
        '(sonst würde es in einer Endlosschleife enden)
        Loop While Not varFind Is Nothing And varFind.Address <> strFindFirst
        End If
    End With
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With
    MsgBox intLoopCount
End Sub
MfG Tom


  

Betrifft: AW: Schnellerer Code Suchen und Kopieren von: Werner
Geschrieben am: 31.10.2014 22:28:11

Hallo Tom,

danke für deine Antwort. Bringt aber leider nichts. Ich habe in den beiden Tabellenblättern keinerlei Formeln.

Gruß Werner


  

Betrifft: AW: Schnellerer Code Suchen und Kopieren von: Daniel
Geschrieben am: 31.10.2014 22:42:03

Hi

Wenn ich deinen Code richtig verstehe, willst du von Tabelle1 alle Zeilen nach Tabelle2 kopieren, bei denen "aktuell" in Spalte 6 steht.

Das geht am schnellsten so:
1. Tabelle1 nach Spalte 6 sortieren.
2. Erste und letzte Zeile mit aktuell finden
3. Alle dazwischen liegenden Zeilen kopieren:

dim Zelle1 as Range
Dim Zelle2 as Range
with Sheets("Tabelle1").usedrange
    .sort key1:=.cells(1, 6), order1:=xlascending, Header:=xlguess
    set Zelle1 = .columns(6).find(what:="aktuell", searchorder:=xlnext)
    set Zelle2 = .columns(6).find(what:="aktuell", searchorder:=xlprevious)
End with
IF not Zelle1 is Nothing then 
    range(zelle1, zelle2).entirerow.copy Sheets("Tabelle2").cells(1, 1)
End if
Bei den .finds habe ich nur die Parameter angegeben, die für das Lösungsprinzip notwendig sind. Für die endgültige Lösung musst du noch sinnvoll ergänzen.

Gruß Daniel


  

Betrifft: AW: Schnellerer Code Suchen und Kopieren von: Werner
Geschrieben am: 31.10.2014 22:56:47

Hallo Daniel,

danke für die Hilfe. Auf das Sortieren wäre ich jetzt nicht gekommen, ist wohl schon ein wenig spät...
Habe deinen Code unverändert reinkopiert und getestet. So sortiert er mir zwar, kopiert dann aber nur die erste Zeile ins Blatt 2.

Gruß Werner


  

Betrifft: AW: Schnellerer Code Suchen und Kopieren von: Daniel
Geschrieben am: 31.10.2014 23:09:07

Dann lade mal deine Datei hoch, damit ich auch testen kann.

Gruß Daniel


  

Betrifft: AW: Schnellerer Code Suchen und Kopieren von: Werner
Geschrieben am: 31.10.2014 23:27:05

Hallo Daniel,

kann ich derzeit leider nicht. Werde sie morgen dann hochladen.

Im Voraus bereits Danke

Werner


  

Betrifft: AW: Schnellerer Code Suchen und Kopieren von: Werner
Geschrieben am: 01.11.2014 05:08:12

Hallo Daniel,

habe das ganze jetzt so gelöst:

Sub LG_suchen()
Dim ws1 As Worksheet
Dim wsQ As Worksheet
Dim wsZ As Worksheet
Dim loLetzte As Range
Dim i As Long
Set ws1 = Worksheets("Tabelle1")
Set wsQ = Worksheets("Tabelle2")
Set wsZ = Worksheets("Tabelle3")
i = 2
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
wsZ.UsedRange.Delete
ws1.UsedRange.Copy wsQ.Cells(1, 1)
wsQ.UsedRange.Sort key1:=wsQ.Cells(1, 6), order1:=xlDescending, Header:=xlGuess
With wsQ.Range("F:F")
Set loLetzte = .Find(What:="Aktuell", After:=.Cells(1), LookIn:=xlValues, LookAt:=xlWhole, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
End With
wsQ.Range(wsQ.Cells(i, 1), wsQ.Cells(loLetzte.Row, 6)).Copy wsZ.Cells(1, 1)
wsQ.UsedRange.Delete
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Da ich meine Original-Daten in ihrer Struktur erhalten will kopiere ich sie zunächst in ein Dummy-Blatt. Dort sortiere ich sie nach Spalte 6. Anschließend kopiere ich die gefilterten Daten die ich brauche in ein weiteres Blatt. Dort werden dann diverse Auswertungen durchgeführt.

Der Denkanstoß in die richtige Richtung ist von dir gekommen. Danke.

Gruß Werner


  

Betrifft: AW: Schnellerer Code Suchen und Kopieren von: Daniel
Geschrieben am: 01.11.2014 10:04:51

Schön dass ich dir helfen konnte, deine eigene Lösung zu finden.
Aber warum so umständlich?
Kopiere die Werte gleich ins Zielblatt, sortiere sie dort und lösche dann alle Zeilen, die nach dem letzten "aktuell" stehen.
Gruß Daniel


  

Betrifft: AW: Schnellerer Code Suchen und Kopieren von: Werner
Geschrieben am: 01.11.2014 17:40:56

Hallo Daniel,

vielleicht kannst du ja noch mal drüber schauen, besser geht schließlich immer.
Das Ding ist nicht für mich, war auch hier im Forum als Beitrag und ich habe mich mal daran versucht.
Die Problematik daran war u.a. dass der Datensatz wohl aus über 30.000 Einträgen besteht. So wie ich beim Googeln festgestellt habe, macht der Autofilter wohl bei einer derartigen Datenmenge Probleme.

https://www.herber.de/bbs/user/93489.xlsm

Gruß Werner


  

Betrifft: AW: Schnellerer Code Suchen und Kopieren von: daniel
Geschrieben am: 01.11.2014 18:34:48

Die Probleme kannst du vermeiden, wenn du die Liste so sortierst, dass alle gefilterten Zeilen möglichst einen lückenlos zusammen hängenden Block bilden.
Die für Excel wichtige grosse ist in vielen Fällen nicht die Anzahl der Zellen, sondern die Anzahl der lückenlos zusammen hängenden Blöcke.
Gruß Daniel


  

Betrifft: AW: Danke für die Hinweise von: Werner
Geschrieben am: 01.11.2014 19:17:29

Hallo Daniel,

danke nochmal für den entscheidenden Denkanstoß.

Gruß Werner


 

Beiträge aus den Excel-Beispielen zum Thema "Schnellerer Code Suchen und Kopieren"