MS-Office-Forum

Zurück   MS-Office-Forum > Microsoft Office > Microsoft Excel
Registrieren Forum Hilfe Alle Foren als gelesen markieren

Banner und Co.

Antworten
Ads
Themen-Optionen Ansicht
Alt 14.04.2019, 12:14   #1
keine Idee
MOF User
MOF User
Standard VBA - UnionRange n-kleinsten finden

Moin zusammen,

ich habe mir einen kleinen Code zusammen geschnipselt der macht was er soll aber bei grösseren Datenmengen sehr langsam ist.

Ich würde mich über Tipps zur Verbesserung der Geschwindigkeit sehr freuen.
Da ich auch schreibfaul bin, bin ich für Hinweise wie der Code ggfs. besser Zusammengefasst werden kann ebenfalls sehr dankbar.

Der Code arbeitet wie folgt:

- ermittelt in nicht zusammenhängenden Zellen einer Zeile den n-kleinsten Wert.
- kopiert n-kleinsten Wert der jeweiligen Range und fügt ihn in eine Zelle die horizontal versetzt ist ein.
- kopiert ebenfalls den Wert der rechts neben dem jeweiligen n-kleinsten Wert liegt und fügt ihn ebenfalls in eine horizontal versetzte Zelle ein.
- abhängig vom ermittelten n-kleinsten Wert wird der Wert in Zeile 1 der gleichen Spalte kopiert und in eine horizontal versetzte Zelle der gleichen Zeile eingefügt.

Code:

Sub Test_UnionRange_n_kleinsten_suchen()

Dim zeile As Long, Zelle As Range
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim rng4 As Range
Dim rngG As Range

zeile = 1
Do While zeile < ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
zeile = zeile + 1

Set rng1 = Tabelle1.Range("U" & zeile)
Set rng2 = Tabelle1.Range("W" & zeile)
Set rng3 = Tabelle1.Range("Y" & zeile)
Set rng4 = Tabelle1.Range("AA" & zeile)
Set rngG = Union(rng1, rng2, rng3, rng4)
For Each Zelle In rngG

If Zelle = WorksheetFunction.Small(rngG, 1) Then
Range("L" & zeile).Value = WorksheetFunction.Small(rngG, 1)
Zelle.Offset(0, 0).Copy Destination:=Range("L" & zeile)
Zelle.Offset(0, 1).Copy Destination:=Range("M" & zeile)
Zelle.End(xlUp).Copy Destination:=Range("N" & zeile)

End If
Next
Loop
End Sub
Ich bin für jeden Hinweis sehr dankbar.
Vorab schonmal vielen Dank.
Frank

__________________

............wenigstens versuchen.
keine Idee ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.04.2019, 12:32   #2
Muller2
MOF User
MOF User
Standard

Hallo,

mach das ganze in Arrays, sortier da um und schreib sie dann zurück ins TabBlatt...

Gruß, Muller2
Muller2 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.04.2019, 12:56   #3
keine Idee
Threadstarter Threadstarter
MOF User
MOF User
Standard VBA - UnionRange n-kleinsten finden

Moin,

das ging ja schnell aber leichter gesagt als getan.
Wie mach ich das ?
Dafür reichen meine Kenntnisse leider (noch) nicht aus.
Wäre schön wenn du mir hierzu einen Beispielansatz geben kannst.

Zu Not habe ich mal eine Testdatei angehängt.

Danke für Feedback
Frank
Angehängte Dateien
Dateityp: xlsm Test_UnionRange_n_Kleinsten.xlsm (15,7 KB, 3x aufgerufen)

__________________

............wenigstens versuchen.
keine Idee ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.04.2019, 16:24   #4
aloys78
MOF Meister
MOF Meister
Standard

Hallo Frank,

Zitat:

Zu Not habe ich mal eine Testdatei angehängt.

Das sollte allerdings Standard bei solchen Aufgabenstellungen sein.

Nachstehend mein Lösungsvorschlag:
Code:

Option Explicit

Sub Test_UnionRange_n_kleinsten_suchen()
    Dim arrI As Variant
    Dim i As Long, i1 As Long, i2 As Long
    Dim arrE As Variant
    Dim LRow As Long
    Const d As Long = 2
    
    LRow = Cells(Rows.Count, "J").End(xlUp).Row
    arrI = Range("J1:Q" & LRow)
    ReDim arrE(1 To UBound(arrI), 1 To 3)
    
    For i = 2 To UBound(arrI)
        i1 = 1: i2 = 3
        Do
            If arrI(i, i1) > arrI(i, i2) Then
                i1 = i2
                i2 = i2 + d
            Else
                i2 = i2 + d
            End If
        Loop Until (i1 > 8 Or i2 > 8)
        arrE(i, 1) = arrI(i, i1)
        arrE(i, 2) = arrI(i, i1 + 1)
        arrE(i, 3) = arrI(1, i1)
    Next i
    Range("A1:C" & LRow) = arrE
End Sub
Gruß
Aloys
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.04.2019, 17:28   #5
keine Idee
Threadstarter Threadstarter
MOF User
MOF User
Standard

Moin Aloys,

wahnsinn läuft extrem schnell.

Leider verstehe ich den Code noch nicht.
Würde ich aber gern um ihn ggfs. anpassen zu können.
Deshalb stelle ich mal ein paar Fragen.
Ich hoffe das ist nicht zu frech.

Für was steht:
- arrI
- i
- arrE
- ReDim arrE(1 To UBound(arrI), 1 To 3)

Wäre schön wenn du mir das noch beantworten könntest.

Ansonsten vielen Dank für die perfekte und schnelle Hilfe.

Greuß
Frank

__________________

............wenigstens versuchen.
keine Idee ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.04.2019, 17:54   #6
aloys78
MOF Meister
MOF Meister
Standard

Hallo Frank,

mit Arrays solltest Du Dich dann mal beschäftigen.
Ich empfehle Dir den Artikel von Bernd Held
Der erste Satz lautet da
"Bei einem Array handelt es sich um eine Tabelle, die im Arbeitsspeicher temporär angelegt wird und für bestimmte Aufgaben benutzt werden kann."

Darauf aufbauend gehe ich auf Deine Fragen ein
arrI = Array zur Übernahme Deiner Tabelle aus den Spalten J:Q
i = Index für diese Array (hier quasi die Zeilen#)
i1,i2 = analog die Spalten# im Array
arrE = Ergebnis-Array (=Ergebnis-Tabelle)

ReDim arrE(1 To UBound(arrI), 1 To 3) = Definition Ergebnis-Array (=Ergebnis-Tabelle)
Ubound(arrI) = obere Grenze Eingabe-Array = obere Zeilen#
1 to Ubound(arrI) = Anzahl Zeilen (genau so viele wie Eingabe-Array)
1 to 3 = 2. Dimension = Anzahl Spalten

Gruß
Aloys
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 14.04.2019, 18:53   #7
keine Idee
Threadstarter Threadstarter
MOF User
MOF User
Standard

Moin Aloys,

vielen Dank für die Erklärungen.
Habe grade bei Hr. Held mal etwas zum Thema bestellt. -

Abschließend noch die Frage wo wird das n-kleinste ermittel ?
Wie bekomme ich den 3 kleinsten Wert etc.

Gruß
Frank

__________________

............wenigstens versuchen.
keine Idee ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.04.2019, 06:48   #8
aloys78
MOF Meister
MOF Meister
Standard

Hallo Frank,

Zitat:

Wie bekomme ich den 3 kleinsten Wert etc.

Bisher war nur vom kleinsten Wert die Rede und genau das macht mein bisheriger Code.

Willst Du aber den x kleinsten Wert suchen, dann muss der Code entsprechend angepasst werden. Dazu mein nachfolgender Code-Vorschlag.
Der x-kleinste Wert ist dann in k zu definieren. Das ist momentan fest programmiert. Man könnte ihn auch jedes Mal erfassen, beispielsweise über eine Datenprüfung.
Code:

Option Explicit

Sub Test_UnionRange_n_kleinsten_suchen()
    Dim arrI As Variant                         ' Ausgangsdaten J:Q
    Dim i As Long                               ' Index 1 (Zeile) für arrI
    Dim i1 As Long, i2 As Long                  ' Index 2 (Spalte) für arrI
    Dim arrE As Variant                         ' Ergebnis
    Dim LRow As Long                            ' # letzte Datenzeile des Bereichs J:Q
    Dim arrZ(1 To 4, 1 To 1) As Variant         ' Arbeitsbereich für die Ermittlung des n-größten Wertes
    Dim z As Long                               ' Index für arrZ
    Dim k As Long                               ' definiert den wieviel kleinsten Wert
    Const d As Long = 2
    
' Festlegen, welcher KKLEINSTE-Wert zugrunde zu legen ist
    k = 3

' Ausgangs-Array erstellen un Ergebnis-Array dimensionieren
    LRow = Cells(Rows.Count, "J").End(xlUp).Row ' # letzte Zeile des Ausgangsbereichs
    arrI = Range("J1:Q" & LRow)                 ' Ausgangsbereich nach Array arrI laden
    ReDim arrE(1 To UBound(arrI), 1 To 3)       ' passe Ergebnis-Array entsprechend an

' zeilenweise den k-kleinsten Wert ermitteln und zugehörige Daten in arrE speichern
    For i = 2 To UBound(arrI)
        
    ' die 4 Werte der Zeile in Array arrZ speichern
        z = 0
        For i1 = 1 To 7 Step 2
            z = z + 1
            arrZ(z, 1) = arrI(i, i1)
        Next i1
        
    ' den k-kleinsten Wert in arrZ ermitteln
        For z = 1 To 4
            If arrZ(z, 1) = WorksheetFunction.Small(arrZ, k) Then
                i1 = z * 2 - 1                  ' I1 = Position des k-kleinsten Wertes in arrI
                Exit For
            End If
        Next z
        
 ' die zugehörigen Werte von k-kleinste in arrE speichern
        arrE(i, 1) = arrI(i, i1)                ' der k-kleinste Were
        arrE(i, 2) = arrI(i, i1 + 1)            ' der zugehörige Nachbarwert
        arrE(i, 3) = arrI(1, i1)                ' die zugehörige Überschrift
    Next i
    
' Array in Tabelle speichern
    LRow = Cells(Rows.Count, "A").End(xlUp).Row ' # letzte Zeile des Ergebnisbereichs
    Range("A1:C" & LRow).ClearContents          ' altes Ergebnis löschen
    Range("A1:C" & LRow) = arrE                 ' neues Eregbnis speichern
End Sub
Gruß
Aloys
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.04.2019, 07:37   #9
Fennek11
MOF Profi
MOF Profi
Standard

Hallo,

ein etwas anderer Ansatz, im sortierten Array fn ist der Index 0 das kleinste, 1 das 2.kleinste usw.

Code:

Sub F_en()
Set Rng = Range("A1:A3,C1:C3")
With CreateObject("System.Collections.ArrayList")
    For Each ar In Rng.Areas
        For i = 1 To ar.Count
            If IsNumeric(Cells(i)) Then .Add ar.Cells(i).Value
        Next i
    Next ar
.Sort

fn = .toArray
For i = 0 To UBound(fn)
    Debug.Print fn(i)
Next i
End With
End Sub
mfg
Fennek11 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.04.2019, 11:19   #10
keine Idee
Threadstarter Threadstarter
MOF User
MOF User
Standard

Moin Aloys,


zunächst vielen, vielen Dank für die Mühe und die Zeit und sorry dafür, dass ich n-kleinste nicht näher erläutert hatte.
Ich lerne daraus zukünftig genauer zu formulieren.

Nochmal kurz zu deinem, für mich genialen Code, den ich versuche zu verstehen.

-Frage zu LRow:
Du weist LRow zweimal eine Range zu. Unterschiedlich für den Ausgangsbereich und den Ergebnisbereich.
Wenn der Ergebnisbereich vor einer zweiten Ausführung des Code gelöscht wird wird der Ergebnisbereich nicht gefüllt da die Zeilennummer nicht mit dem Ausgangsbereich übereinstimmt.
Ich habe LRow für Ausgangsbereich und Ergebisbereich die gleiche Range zugewiesen damit ich das Problem umgehe.
Mache ich da einen Denkfehler und produziere damit ein Problem an einer anderer Stelle ???

- Frage zu arrZ
(Dim arrZ(1 To 4, 1 To 1) As Variant)
Steht die 4 für die 4 zu erwartenden Ergebnisse der 8 Spalten ?

- Frage zu i1
(i1 = 1 To 7 Step 2)
Ich interpretiere es so:
Jede zweite Spalte im Bereich 1-7.
Warum 1-7 ???
Müsste es nicht 0-7 oder 1-8 heissen ?

Ich hoffe du versteht meine Nachfragen nicht falsch.
Du hast dir sehr viel Mühe gegeben und ich versuche wirklich zu verstehen und anschließend selbst anpassen zu können.


Vielen Dank
Frank

@ Fennek11 selbstverstänlich auch dir meinen herzlichen Dank.

__________________

............wenigstens versuchen.
keine Idee ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.04.2019, 16:51   #11
aloys78
MOF Meister
MOF Meister
Standard

Hallo Frank,

Zitat:

Nochmal kurz zu deinem, für mich genialen Code, ...

den ich eher als bodenständig bezeichnen würde.

Ansonsten versuche ich nachstehend, Deine Lernfragen zu beantworten:

Zitat:

Du weist LRow zweimal eine Range zu. Unterschiedlich für den Ausgangsbereich und den Ergebnisbereich.
Wenn der Ergebnisbereich vor einer zweiten Ausführung des Code gelöscht wird wird der Ergebnisbereich nicht gefüllt da die Zeilennummer nicht mit dem Ausgangsbereich übereinstimmt.

Zum einen: LRow (=Last Row) ist keine Range, sondern eine numerische Variable, die die Nummer der letzten Zeile enthält; zuerst für die Übertragung des Ausgangsbereich ins Array arrI, und am Schluß, bevor das Ergebnis-Array arrE in die Tabelle kopiert wird, für das Löschen eines eventuell noch vorhandenen (alten) Ergebnisbereiches.

Welches Problem da bei Dir auftritt, kann ich daher nicht nachvollziehen.

Zitat:

(Dim arrZ(1 To 4, 1 To 1) As Variant)
Steht die 4 für die 4 zu erwartenden Ergebnisse der 8 Spalten ?

arrZ ist nur ein(e) Hilfs-Array bzw Hilfs-Tabelle, die für jede Zeile die für die KKLEINSTE-Auswertung relevanten Werte der Sp J, L, N und P enthält.
Im Ausgangs-Array sind diese Werte unter der Position 1, 3, 5 und 7 anzusprechen.

Anbei meine Testversion, die neben dem Button in H2 noch eine Datenprüfung für die Auswahl eines x-ten KKleinsten Wert erlaubt.

Gruß
Aloys
Angehängte Dateien
Dateityp: xlsm Frank_Test_UnionRange_n_Kleinsten V3.xlsm (28,4 KB, 2x aufgerufen)
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.04.2019, 17:37   #12
keine Idee
Threadstarter Threadstarter
MOF User
MOF User
Standard

Moin Aloys,

zunächst vielen Dank für die Bereitschaft und die Geduld.

Zitat:

Zum einen: LRow (=Last Row) ist keine Range, sondern eine numerische Variable, die die Nummer der letzten Zeile enthält; zuerst für die Übertragung des Ausgangsbereich ins Array arrI, und am Schluß, bevor das Ergebnis-Array arrE in die Tabelle kopiert wird, für das Löschen eines eventuell noch vorhandenen (alten) Ergebnisbereiches.

Ich lerne daraus "Genauigkeit durch Begrifflichkeit". Trotz grösster Anstrengungen habe ich noch Luft nach oben.

Zitat:

Welches Problem da bei Dir auftritt, kann ich daher nicht nachvollziehen.

Das Problem entsteht wenn du den Code ausführst, das Ergebniss löschst und dann den Code ein zweites Mal ausführst.

Danke für die Erklärung zu arrZ.
Ich beginne den Code langsam zu verstehen.

Letzte Frage:

Wofür ist i2 verantwortlich ?

P.S.

In der Zwischenzeit habe ich ihn angepasst.
58 Spalten und 115790 Zeilen. ca. 30 sek.
Absoluter Wahnsinn.
Mein alter Code lief ca. 4 Stunden.
Damit hast du mir ne Menge Lebenszeit geschenkt.

__________________

............wenigstens versuchen.
keine Idee ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.04.2019, 20:40   #13
aloys78
MOF Meister
MOF Meister
Standard

Hallo Frank,

der Punkt geht an Dich.

1. die Variable I2 kannst Du entfernen, die wird in der neuen Version nicht mehr benötigt.

2. Das LRow-Problem ist gelöst, wenn Du den letzten Code-Block durch den folgenden ersetzt.
Code:

' Array in Tabelle speichern
    LRow = Cells(Rows.Count, "A").End(xlUp).Row ' # letzte Zeile des Ergebnisbereichs
    Range("A1:C" & LRow).ClearContents          ' altes Ergebnis löschen
    LRow = Cells(Rows.Count, "J").End(xlUp).Row ' # letzte Zeile des Ausgangsbereichs
    Range("A1:C" & LRow) = arrE                 ' neues Eregbnis speichern
End Sub
Gruß
Aloys
aloys78 ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Alt 15.04.2019, 21:06   #14
keine Idee
Threadstarter Threadstarter
MOF User
MOF User
Standard

Moin Aloys,

vielen Dank für die Antwort und den Punkt.
Da bin ich ein bisschen stolz auf mich und ich hoffe es zeigt, dass ich mich mit dem Thema beschäftige und nicht einfach jemanden suche der das für mich erledigt.
Mittlerweile sind auch die Unterlagen von Hr. Held angekommen.
Mittwoch gehts in den Urlaub. Dann hab ich etwas zu lesen.


Vielen Dank.
Frank

__________________

............wenigstens versuchen.
keine Idee ist offline  
verlinken auf Del.icio.us Diese Seite zu Mister Wong hinzufügen
Antworten Auf Beitrag antworten
Ads
Antworten


Aktive Benutzer in diesem Thema: 1 (Registrierte Benutzer: 0, Besucher: 1)
 
Themen-Optionen
Ansicht

Forumregeln
Es ist Ihnen nicht erlaubt, neue Themen zu verfassen.
Es ist Ihnen nicht erlaubt, auf Beiträge zu antworten.
Es ist Ihnen nicht erlaubt, Anhänge anzufügen.
Es ist Ihnen nicht erlaubt, Ihre Beiträge zu bearbeiten.

vB Code ist An.
Smileys sind An.
[IMG] Code ist An.
HTML-Code ist An.
Gehe zu


Alle Zeitangaben in WEZ +1. Es ist jetzt 00:01 Uhr.



Powered by: vBulletin Version 3.6.2 (Deutsch)
Copyright ©2000 - 2019, Jelsoft Enterprises Ltd.

Copyright ©2000-2018 MS-Office-Forum. Alle Rechte vorbehalten.
Copyright ©Design: Manuela Kulpa ©Rechte: Günter Kramer
Eine Verwendung der Inhalte in anderen Publikationen, auch auszugsweise,
ist ohne ausdrückliche Zustimmung der Autoren nicht gestattet.