Live-Forum - Die aktuellen Beiträge
Datum
Titel
19.04.2024 14:04:05
PDF per VBA ausgeben - Seitenskalierung
19.04.2024 13:58:02
Set Worksheet geht im O365 aber im Excel 2016 nicht
19.04.2024 13:49:38
Per Kopfdruck als pdf speichern und Mail erstellen
19.04.2024 12:58:59
Daten einfügen aus anderem Sheet
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1120to1124
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1120to1124
1120to1124
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

ARRAY-Spezialist gesucht

ARRAY-Spezialist gesucht
Peter
Hallo Excel-Spezialisten,
für eine Freundin in der Schweiz soll ich aus einer Matrix jede Zeile mit allen anderen vergleichen und die gefundenen Zahlen in einem neuen Tabellenblatt ausgeben.
Also alle Zahle der Zeile 1 gegen die Zahlen der Zeile 2, der Zeile 3, der Zeile n dann
alle Zahlen der Zeile 2 gegen die Zahlen der Zeile 3, der Zeile 4, der Zeile n
bis zur Zeile 83 gegen 84.
Mein Makro läuft doch recht lange und da dacht ich, dass das mit Arrays schneller gehen könnte.
Nur im Augenblick bin ich nicht recht in der Lage das zu realisieren.
Vielleicht kann ja jemand einen Blick auf das zweite Makro werfen und es gangbar machen.
Vielen Dank schon einmal im voraus.
Gruß Peter https://www.herber.de/bbs/user/66333.zip

20
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
Bin kein Spezialist
02.12.2009 21:03:16
werni
Hallo Peter
Das sind über 1Mio vergleiche und über 100T Eingaben.
Vorhandensein_I dauert bei mir ca. 19Sek.
Vorhandensein_II schreibt nur eine Zeile und dauert 6Sek.
Gruss Werner
AW: Bin kein Spezialist
02.12.2009 21:12:34
Peter
Hallo Werner,
Deine Antwort hilft mir leider gar nicht weiter, denn die Erkenntnisse hatte ich bereits.
Ich meine aber, dass eine Array-Lösung schneller sein müsste und damit (für mich) auch sehr interessant wäre.
Gruß Peter
AW: Bin kein Spezialist
02.12.2009 21:28:14
Klaus-Dieter
Hallo Peter,
da ich auch zu einer Zeit in der Größenordnung von Werner gekommen war, habe ich das nicht weiter verfolgt. Rund 20 Sekunden sind doch nicht sehr lange, selbst wenn sich das per Array eventuell auf 2 - 3 Sekunden verkürzen ließe, steht dem ja eine gewisse Programmierzeit gegenüber.
Grundsätzlich scheint es mir so, dass du nicht berücksichtigt hast, das Arrays unterschiedliche Zählweisen haben.
Dein Array vTemp_E beginnt die Felder bei 1 zu zählen, da es auf einen "Schuß" gefüllt wird.
Dagegen beginnt vTemp_A bei 0 zu zählen, da es Feldweise gefüllt wird.
Viele Grüße Klaus-Dieter

Online-Excel
Anzeige
ein Ansatz mit Hashes
02.12.2009 21:57:21
Christian
Hallo Peter,
hier ein Ansatz mit Hashes - in VB heißt das wohl Dictionary - allgemein assoziatives Array.
Das ganze lässt sich bestimmt noch weiter beschleunigen - ist ja nur ein Ansatz.
Auf meiner alten Leierbüchse braucht dein "Vorhandensein_I" ca. 59 Sek., derHash-Ansatz nur 9 Sek.
Gruß
Christian Option Explicit Sub testit() Dim wks As Worksheet Dim i&, j&, k&, m&, p&, lngLR&, lngLC&, strTxt$ Dim hshSrc As Object, hshComp As Object Set hshSrc = CreateObject("Scripting.Dictionary") Set hshComp = CreateObject("Scripting.Dictionary") Set wks = ThisWorkbook.Worksheets("Vorhandene") Application.ScreenUpdating = False wks.Cells.ClearContents With ThisWorkbook.Worksheets("allezu") lngLR = .Cells(.Rows.Count, 1).End(xlUp).Row For i = 1 To lngLR - 1 hshSrc.RemoveAll For j = 1 To .Cells(i, .Columns.Count).End(xlToLeft).Column strTxt = .Cells(i, j).Text hshSrc(strTxt) = strTxt Next For k = i + 1 To lngLR hshComp.RemoveAll For p = 1 To .Cells(k, .Columns.Count).End(xlToLeft).Column strTxt = .Cells(k, p).Text If hshSrc.exists(strTxt) Then hshComp(strTxt) = strTxt End If Next m = m + 1 wks.Cells(m, 1) = i & "|" & k wks.Cells(m, 2).Resize(, hshComp.Count) = hshComp.Items Next Next End With Application.ScreenUpdating = True End Sub
Anzeige
Super nur 7Sek.
02.12.2009 22:07:02
werni
Hi Christian
Tolle Sache
Gruss Werner
AW: ein Ansatz mit Hashes
02.12.2009 22:10:25
Peter
Hallo Klaus-Dieter,
danke für Deinen Ansatz. Der benötigt bei mir knapp 21 Sek., während meine laufende Version knapp 90 Sek. benötigt. Das ist ja schon fast nur noch 1/4 meiner Laufzeit.
Ich kenne nun nicht den schweizer Rechner, auf dem das laufen soll - und kann nur hoffen, dass der schneller als meiner ist.
Gruß Peter
AW: ein Ansatz mit Hashes
02.12.2009 22:12:38
Peter
Hallo Christian,
leider habe ich Dich falsch angeredet - das tut mir sehr leid.
Gruß Peter
auch kein Spezialist
02.12.2009 22:27:22
ransi
HAllo
Bin zwar auch kein Spezialist, aber hab mich trotzdem mal dran versucht....
Ca. 1, 7 Sekunden.
Teste mal selber:
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit


Public Sub machs()
Dim WkSh_Q As Worksheet ' das Quell-Tabellenblatt - die Herkunft der Daten
Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - die Ausgabe
Set WkSh_Q = ThisWorkbook.Worksheets("allezu")
Set WkSh_Z = ThisWorkbook.Worksheets("TAbelle3")
Dim T As Double
Dim myDic As Object
Dim arr As Variant
Dim spl As Variant
Dim i As Long
Dim L As Long
Dim v As Variant
Dim out As Variant
Dim z As Long
Dim a As Long
Dim B As Long
Dim C As Long
T = Timer
WkSh_Q.Range("A1").CurrentRegion.Copy
arr = Split(HoleTextVonZwischenablage, vbCrLf)
Set myDic = CreateObject("Scripting.Dictionary")
For L = 0 To UBound(arr) - 1
    spl = Split(arr(L), vbTab)
    myDic.RemoveAll
    For i = LBound(spl) To UBound(spl)
        myDic(spl(i)) = 0
    Next
    For C = L + 1 To UBound(arr) - 1
        v = Split(arr(C), vbTab)
        a = 0
        Redim out(a)
        For z = LBound(v) To UBound(v)
            If myDic.exists(v(z)) Then
                Redim Preserve out(a)
                out(a) = v(z)
                a = a + 1
            End If
        Next
        B = B + 1
        WkSh_Z.Cells(B, 1).Resize(1, UBound(out)) = out
    Next
Next
MsgBox Timer - T
End Sub


Public Function HoleTextVonZwischenablage() As String
Dim oData As New DataObject
On Error Resume Next ' Brutal um falsche Formate abzuwürgen, gibt dann einen Leerstring
oData.GetFromClipboard
HoleTextVonZwischenablage = oData.GetText
End Function


ransi
Anzeige
AW: auch kein Spezialist
02.12.2009 22:42:23
werni
Hi Ransi
Unter Excel9 Fehler
Userbild
Gruss Werner
fm20.dll
02.12.2009 22:46:48
ransi
HAllo Werni
Da fehlt nur ein Verweis auf die fm20.dll.
Füge mal eine Userform ein.
Kannst du dann auch sofort wieder löschen.
Dann sewtzt sich der Verweis automatisch.
ransi
2.59Sek Toll
02.12.2009 22:55:03
werni
Hi Ransi
Hat geklappt. Musste nach dem Einfügen der Userform zuerst Excel schliessen.
Gruss Werner
AW: Unterschied
03.12.2009 00:02:51
Christian
Hallo Werner,
das hätte ich jetzt auch nicht mehr überprüft...
Aber, du hast recht:
zB: beim Vergleich von Zeile 1 mit Zeile 25:
- mein Code listet "8; 18; 22; 23; ..."
- Ransis Code listet "18; 22; 23; ..."
Wenn man die Tabelle "allezu" heranzieht sieht man, dass Ransi hier die "8" verschluckt. Das ist bestimmt nur 'ne Kleinigkeit.
Wie schon in meinem ersten Posting erwähnt war mir klar, dass ich bei meinem Ansatz noch böse Bremsen drin habe, insbesondere wird dabei noch viel zu oft auf einzelne Zellen zugegriffen bzw. geschrieben.
Ransi zieht gleich alles in ein Array und arbeitet mit diesem weiter. Ebenso wird das Ergebnis nicht zeilenweise sondern komplett in die Tabelle geschrieben. Das ist bekanntlich sehr viel schneller.
Allerdings würde ich hier auf den Verweis auf die Dll verzichten.
Den dabei eingehandelten Performance-Verlust (Split funktioniert dann nicht mehr) kann man aber wieder wett machen, wenn man im weiteren Code auf die "Redim's" verzichtet und statt dessen vorher die Dimension des "Ziel-Arrays" mit einer geeigneten Funktion berechnet.
Grüße
Christian
Anzeige
AW: Unterschied
03.12.2009 09:50:52
ransi
HAllo
zB: beim Vergleich von Zeile 1 mit Zeile 25:
...- Ransis Code listet "18; 22; 23; ..."
Hm ?
Kann ich so nicht stehen lassen!
Tabelle3

 ABCDEFGHIJKLMNOPQRSTUVWXYZAAAB
248182223252630333540414243464951555658596166677274777885


Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
Wer zählt nach was richtig ist?
Vieleicht beide.
Kommt drauf an wie man sowas auswertet:
allezu

 LMNO
2422232324


allezu

 KLMN
4524252526


Excel Tabellen im Web darstellen >> Excel Jeanie HTML 4
ransi
Anzeige
AW: Unterschied
03.12.2009 10:44:04
ransi
HAllo
Die Copy-Geschichte aus dem ersten Code war ein Überbleibsel von meinem ersten Versuch.
Da wollte ich das mit einem Regex lösen.
Habe die Anregungen von Christian mal aufgegriffen und noch etwas optimiert.
Laufzeit ca. 0,7 sekunden.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit



Public Sub test()
Dim WkSh_Q As Worksheet ' das Quell-Tabellenblatt - die Herkunft der Daten
Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - die Ausgabe
Dim T As Double
Dim myDic As Object
Dim arr As Variant
Dim out As Variant
Dim L As Long
Dim i As Integer
Dim Z As Long
Dim C As Long
Dim A As Integer
T = Timer
Set WkSh_Q = ThisWorkbook.Worksheets("allezu")
Set WkSh_Z = ThisWorkbook.Worksheets("Tabelle3")
Set myDic = CreateObject("Scripting.Dictionary")
arr = WkSh_Q.Range("A1").CurrentRegion
Redim out(1 To UBound(arr, 2))
For L = LBound(arr, 1) To UBound(arr, 1) - 1
    myDic.removeall
    For i = LBound(arr, 2) To UBound(arr, 2)
        myDic(arr(L, i)) = 0
    Next
    For C = L + 1 To UBound(arr)
        A = 1
        out(A) = "'" & L & "/" & C
        A = A + 1
        For i = LBound(arr, 2) To UBound(arr, 2)
            If myDic.exists(arr(C, i)) Then
                out(A) = arr(C, i)
                A = A + 1
            End If
        Next
        Z = Z + 1
        WkSh_Z.Cells(Z, 1).Resize(1, UBound(out)) = out
    Next
Next
MsgBox Timer - T
End Sub


Selbst da ist noch Optimierungspotenzial vorhanden.
ransi
Anzeige
Kleine aber entscheidende Korrektur
03.12.2009 10:59:38
ransi
Hallo
Vergiss den letzten Post.
Ist ein ganz grober Fehler drin.
So gehts:
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit



Public Sub test()
Dim WkSh_Q As Worksheet ' das Quell-Tabellenblatt - die Herkunft der Daten
Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - die Ausgabe
Dim T As Double
Dim myDic As Object
Dim arr As Variant
Dim out As Variant
Dim L As Long
Dim i As Integer
Dim Z As Long
Dim C As Long
Dim A As Integer
T = Timer
Set WkSh_Q = ThisWorkbook.Worksheets("allezu")
Set WkSh_Z = ThisWorkbook.Worksheets("Tabelle3")
Set myDic = CreateObject("Scripting.Dictionary")
arr = WkSh_Q.Range("A1").CurrentRegion
For L = LBound(arr, 1) To UBound(arr, 1) - 1
    myDic.removeall
    For i = LBound(arr, 2) To UBound(arr, 2)
        myDic(arr(L, i)) = 0
    Next
    For C = L + 1 To UBound(arr)
        A = 1
        Redim out(1 To UBound(arr, 2) + 1)
        out(A) = "'" & L & "/" & C
        A = A + 1
        For i = LBound(arr, 2) To UBound(arr, 2)
            If myDic.exists(arr(C, i)) Then
                out(A) = arr(C, i)
                A = A + 1
            End If
        Next
        Z = Z + 1
        WkSh_Z.Cells(Z, 1).Resize(1, UBound(out)) = out
    Next
Next
MsgBox Timer - T
End Sub


ransi
Anzeige
AW: Kleine aber entscheidende Korrektur
03.12.2009 11:09:31
Tino
Hallo,
wenn Du die Value2 Variante nimmst und die Deklarierung als Array vornimmst,
kannst Du noch eine zehntel Sekunde rausschlagen.
Dim arr() As Variant
Dim out() As Variant
arr = WkSh_Q.Range("A1").CurrentRegion.Value2
ReDim out(1 To UBound(arr, 2))
Gruß Tino
AW: Kleine aber entscheidende Korrektur
03.12.2009 11:45:03
Christian
Hallo Ransi,
Du hast recht, mein Hinweis von gestern abend war falsch...irgendwie hatte ich die Spalte A nicht mit ein bezogen.
Aber schau mal auf 1/24 - da hast du 2 mal die 23 drin.
gruß
Christian
ohne Duplikate
03.12.2009 12:11:37
ransi
HAllo Christian
Das schrieb ich doch hier:
https://www.herber.de/forum/messages/1121532.html
Ist aber auch kein Problem.
Kann man auch ohne großen Aufwand berücksichtigen.
' **********************************************************************
' Modul: Modul3 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit



Public Sub test()
Dim WkSh_Q As Worksheet ' das Quell-Tabellenblatt - die Herkunft der Daten
Dim WkSh_Z As Worksheet ' das Ziel-Tabellenblatt - die Ausgabe
Dim T As Double
Dim myDic As Object
Dim arr() As Variant
Dim out() As Variant
Dim L As Long
Dim i As Integer
Dim C As Long
Dim A As Integer
Dim K As Long
T = Timer
Set WkSh_Q = ThisWorkbook.Worksheets("allezu")
Set WkSh_Z = ThisWorkbook.Worksheets("Tabelle3")
Set myDic = CreateObject("Scripting.Dictionary")
arr = WkSh_Q.Range("A1").CurrentRegion.Value2
Redim Preserve arr(1 To UBound(arr), 1 To UBound(arr, 2) + 1)
Redim out(1 To UBound(arr) * UBound(arr, 2), 1 To UBound(arr, 2) + 1)
For L = LBound(arr, 1) To UBound(arr, 1) - 1
    myDic.removeall
    For i = LBound(arr, 2) To UBound(arr, 2)
        myDic(arr(L, i)) = 0
    Next
    For C = L + 1 To UBound(arr)
        A = 1
        K = K + 1
        out(K, A) = "'" & L & "/" & C
        A = A + 1
        For i = LBound(arr, 2) To UBound(arr, 2) - 1
            If arr(C, i) <> arr(C, i + 1) Then
                If myDic.exists(arr(C, i)) Then
                    out(K, A) = arr(C, i)
                    A = A + 1
                End If
            End If
        Next
    Next
Next
WkSh_Z.Cells(1, 1).Resize(UBound(out), UBound(out, 2)) = out
MsgBox Timer - T
End Sub


ransi
Anzeige
AW: auch kein Spezialist
03.12.2009 14:40:15
Peter
Hallo ransi,
mir scheint der Spezialist aber 'fast' erreicht zu sein!!!
Danke für Dein Makro, ich werde mich hineinvertiefen.
Auf meinem müden Rechner braucht es immerhin nur 1,65625 Sek.
Gegenüber meinem Versuch, mit heute 78,359 Sek. und dem Makro von Christian mit 18,828 Sek. ist das schon eine erhebliche Verbesserung.
Nun werde ich die drei Varianten in die Schweiz weiterleiten und dann das dortige Echo abwarten.
Danke allen Beteiligten an der Anteilnahme an meinem 'Problem'.
Gruß Peter

Links zu Excel-Dialogen

UserForm

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige