HERBERS Excel-Forum - das Archiv
Bewerten Sie hier bitte das Excel-Portal
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

Bin kein Spezialist
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
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
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
ein Ansatz mit Hashes
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
Super nur 7Sek.
werni

Hi Christian
Tolle Sache
Gruss Werner
AW: ein Ansatz mit Hashes
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
Peter

Hallo Christian,
leider habe ich Dich falsch angeredet - das tut mir sehr leid.
Gruß Peter
auch kein Spezialist
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
AW: auch kein Spezialist
werni

Hi Ransi
Unter Excel9 Fehler
Userbild
Gruss Werner
fm20.dll
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
werni

Hi Ransi
Hat geklappt. Musste nach dem Einfügen der Userform zuerst Excel schliessen.
Gruss Werner
Unterschied
werni

Hi All
Wer zählt nach was richtig ist?
https://www.herber.de/bbs/user/66336.htm
Gruss Werner
AW: Unterschied
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
AW: Unterschied
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
AW: Unterschied
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
Kleine aber entscheidende Korrektur
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
AW: Kleine aber entscheidende Korrektur
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
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
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
AW: auch kein Spezialist
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