Microsoft Excel

Herbers Excel/VBA-Archiv

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

ARRAY-Spezialist gesucht | Herbers Excel-Forum


Betrifft: ARRAY-Spezialist gesucht von: Peter Feustel
Geschrieben am: 02.12.2009 19:02:35

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

  

Betrifft: Bin kein Spezialist von: werni
Geschrieben am: 02.12.2009 21:03:16

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


  

Betrifft: AW: Bin kein Spezialist von: Peter Feustel
Geschrieben am: 02.12.2009 21:12:34

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


  

Betrifft: AW: Bin kein Spezialist von: Klaus-Dieter
Geschrieben am: 02.12.2009 21:28:14

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

Klaus-Dieter's Excel und VBA Seite
Online-Excel



  

Betrifft: ein Ansatz mit Hashes von: Christian
Geschrieben am: 02.12.2009 21:57:21

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



  

Betrifft: Super nur 7Sek. von: werni
Geschrieben am: 02.12.2009 22:07:02

Hi Christian

Tolle Sache

Gruss Werner


  

Betrifft: AW: ein Ansatz mit Hashes von: Peter Feustel
Geschrieben am: 02.12.2009 22:10:25

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


  

Betrifft: AW: ein Ansatz mit Hashes von: Peter Feustel
Geschrieben am: 02.12.2009 22:12:38

Hallo Christian,

leider habe ich Dich falsch angeredet - das tut mir sehr leid.

Gruß Peter


  

Betrifft: auch kein Spezialist von: ransi
Geschrieben am: 02.12.2009 22:27:22

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


  

Betrifft: AW: auch kein Spezialist von: werni
Geschrieben am: 02.12.2009 22:42:23

Hi Ransi

Unter Excel9 Fehler



Gruss Werner


  

Betrifft: fm20.dll von: ransi
Geschrieben am: 02.12.2009 22:46:48

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


  

Betrifft: 2.59Sek Toll von: werni
Geschrieben am: 02.12.2009 22:55:03

Hi Ransi

Hat geklappt. Musste nach dem Einfügen der Userform zuerst Excel schliessen.

Gruss Werner


  

Betrifft: Unterschied von: werni
Geschrieben am: 02.12.2009 23:12:14

Hi All

Wer zählt nach was richtig ist?
https://www.herber.de/bbs/user/66336.htm

Gruss Werner


  

Betrifft: AW: Unterschied von: Christian
Geschrieben am: 03.12.2009 00:02:51

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


  

Betrifft: AW: Unterschied von: ransi
Geschrieben am: 03.12.2009 09:50:52

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


  

Betrifft: AW: Unterschied von: ransi
Geschrieben am: 03.12.2009 10:44:04

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


  

Betrifft: Kleine aber entscheidende Korrektur von: ransi
Geschrieben am: 03.12.2009 10:59:38

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


  

Betrifft: AW: Kleine aber entscheidende Korrektur von: Tino
Geschrieben am: 03.12.2009 11:09:31

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


  

Betrifft: AW: Kleine aber entscheidende Korrektur von: Christian
Geschrieben am: 03.12.2009 11:45:03

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


  

Betrifft: ohne Duplikate von: ransi
Geschrieben am: 03.12.2009 12:11:37

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


  

Betrifft: AW: auch kein Spezialist von: Peter Feustel
Geschrieben am: 03.12.2009 14:40:15

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