Microsoft Excel

Herbers Excel/VBA-Archiv

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

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

Makro Reiterverweismatrix

Betrifft: Makro Reiterverweismatrix von: Steffen
Geschrieben am: 05.09.2014 17:30:33

Hallo liebe Excler!

Ich habe ein Makro erstellt, welches mir in einer Matrix die Anzahl der Verweise von Sheet zu Sheet auflisten soll.

Dazu werden 2 Sheets angelegt: (1) SheetMatrixOverview & (2) SheetSearchList

Prinzip:
1. A: Reiternamen auflisten
2. Loop ersten Suchbegriff (reiternamen) aus A auswählen und die komplette Mappe danach durchsuchen, bei Treffern:
3. C: Zelle eintragen
4. D: Reiter (in dem Verweis gefunden wurde) eintragen
5. nächster Suchbegriff aus A

Problem: Ich möchte das Makro effizienter und robuster machen, indem die Mappe nur einmal nach allen Suchbegriffen gleichzeitig durchsucht wird (Bei 100 Reitern mit Werten wird das Makro extrem langsam -> ExcelCrash)
Ich habe mich dem Problem versucht via Array oder ähnlichem anzunähern und komme nicht weiter.

und später noch:
6. via indirect Wert auslesen und einige andere Formeln

Die Originalexcel kann ich leider nicht hochladen, da sie extrem groß ist.

Hier der VBA-Code:

Sub Hirn()
    Dim strFilename As String
    Dim wkbMappe As Workbook 'neue Mappe
    Dim AmountSheets As Long 'Reiteranzahl auslesen
    Dim WS As Worksheet
    
    For Each WS In ActiveWorkbook.Worksheets
    WS.Visible = xlSheetVisible
    Next WS
    Application.Calculation = xlCalculationManual 'automat.Berechnung ausschalten
    
    ChDrive "c:\"
    ChDir "\temp\"
    strFilename = ("SheetLinksMatrixOverview" & Format(Date, "yyyymmdd") & ".xlsx")
    Application.Dialogs(xlDialogSaveAs).Show (strFilename)
    strFilename = ActiveWorkbook.Name
    'SheetMatrixOverview
    For Each WS In Worksheets
        If WS.Name = "SheetMatrixOverview" Then WS.Delete
    Next WS
        Worksheets.Add Before:=Worksheets(1)
        ActiveSheet.Name = "SheetMatrixOverview"
    'SheetSearchList
    For Each WS In Worksheets
        If WS.Name = "SheetSearchList" Then WS.Delete
    Next WS
        Worksheets.Add after:=Worksheets(1)
        ActiveSheet.Name = "SheetSearchList"
        
    ' Suchlegende erstellen mit Umbennenung in Folgespalte
    Sheets("SheetSearchList").Activate
    For AmountSheets = 3 To Workbooks(strFilename).Worksheets.Count '5 durch 2 ersetzen
        Cells(1, 1).Value = "Suchbegriffe:"
        Cells(AmountSheets - 1, 1).Value = "'" & Workbooks(strFilename).Sheets(AmountSheets). _
Name & "'!"
    Next AmountSheets
    
    
        ' Begin Suchschleife nach Begriffen in Spalte B ab B2
    Dim X As Integer
    X = 2
    Do Until IsEmpty(Worksheets("SheetSearchList").Cells(X, 1))
        B = Worksheets("SheetSearchList").Cells(X, 1)
    
                Dim strFind As String
                Dim rng As range
                Dim strAddress As String
                Dim Z As Integer
                
                strFind = B
                
                If strFind = "" Then MsgBox ("idiot") ' <- höhö
                    For Each WS In Worksheets
                        Set rng = WS.Cells.Find(strFind)
                    If Not rng Is Nothing Then
                        strAddress = rng.Address
                        Do
                        On Error GoTo Error
                            Application.Goto rng
                            With Worksheets("SheetSearchList")
                                Z = 1
                                Do Until IsEmpty(Worksheets("SheetSearchList").Cells(Z + 1, 3))
                                Z = Z + 1
                                Loop
                                Z = Z + 1
                                Worksheets("SheetSearchList").Cells(Z, 3) = rng.Address
                                Worksheets("SheetSearchList").Cells(Z, 4) = rng.Worksheet.Name
                            End With
                                Set rng = WS.Cells.FindNext(after:=ActiveCell)
                                Loop While rng.Address <> strAddress
                            End If
                        Next WS
                        
                    'Application.Goto Worksheets(1).Range("A1")    Später
                    Set rng = Nothing
    X = X + 1
    Loop
    Sheets("SheetSearchList").Activate
                    '2te Tabelle
                    Worksheets("SheetSearchList").Cells(1, 3) = "Cell:"
                    Worksheets("SheetSearchList").Cells(1, 4) = "Location:"
                    Worksheets("SheetSearchList").Cells(1, 5) = "Value:"
                    Worksheets("SheetSearchList").Cells(2, 5).FormulaLocal = "=IF(AND(C2=""""; _
D2="""");"""";INDIRECT(""'""&D2&""'!""&C2))"
                    
                    'Für die dritte Tabelle
                    Dim AmountSearchedSheets As Long
                    AmountSearchedSheets = range(range("A1"), range("A1").End(xlDown)).Rows. _
Count

                    'dritte Tabelle
                    Worksheets("SheetSearchList").Cells(1, 7) = "Auf wen wird verlinkt:"
                    Worksheets("SheetSearchList").Cells(2, 7).FormulaLocal = "=IF(AND(C2=""""; _
D2="""");"""";IF(ISNUMBER(MATCH(E2;$A$2:$A$" & AmountSearchedSheets & ";0));E2;G1))"
                    Worksheets("SheetSearchList").Cells(2, 8).FormulaLocal = "=IF(G2="""";""""; _
LEFT(G2;LEN(G2)-2))"
                    
                    'Fürs Runterziehen
                    Dim AmountValues As Long
                    AmountValues = range(range("C2"), range("C2").End(xlDown)).Rows.Count + 1
                    
                    'Runterziehen
                    range("E2:H2").Select
                        Selection.Copy
                        range("E2:H" & AmountValues + 1).Select
                        ActiveSheet.Paste
                        Application.CutCopyMode = False
        'Matrixformel
        Sheets("SheetMatrixOverview").Activate
                    For AmountSheets = 3 To Workbooks(strFilename).Worksheets.Count
                        Cells(AmountSheets - 1, 1).Value = Workbooks(strFilename).Sheets( _
AmountSheets).Name
                        Cells(1, 1).Value = "Matrix:"
                        Cells(1, AmountSheets - 1).Value = Workbooks(strFilename).Sheets( _
AmountSheets).Name
                    Next AmountSheets
                    Worksheets("SheetMatrixOverview").Cells(2, 2).FormulaLocal = "=COUNTIFS( _
SheetSearchList!$D$2:$D$" & AmountValues & ";SheetMatrixOverview!$A2;SheetSearchList!$H$2:$H$" & AmountValues & ";SheetMatrixOverview!B$1)"
        'Letzten Spaltenbuchstaben
                    Dim strAdd As String
                    Dim strLetter As String
                    strAdd = Mid((Cells(1, AmountSearchedSheets).Address), 2, Len(Cells(1,  _
AmountSearchedSheets).Address) - 3)
        'Matrix runterziehen
                            range("B2").Select
                            Selection.Copy
                            range("B2:" & strAdd & AmountSearchedSheets).Select
                            ActiveSheet.Paste
                            Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic 'automat.Berechnung einschalten
Exit Sub
Error:
                        Application.Calculation = xlCalculationAutomatic 'automat.Berechnung  _
einschalten falls ein Fehler ausgegeben wird
                        MsgBox ("Error 404 - Page not Found")
End Sub


Viel Spaß beim tüffteln!
Wenn ich eine Lösung finde werde ich sie hier posten!

  

Betrifft: AW: Makro Reiterverweismatrix von: Franc
Geschrieben am: 05.09.2014 17:46:31

Wenn es nirgends anders ausgeschaltet wird dann fehlt schon mal das hier
am anfang
Application.ScreenUpdating = False

am ende vor "exit sub" und auch einmal bei "Error:"
Application.ScreenUpdating = True

Das löst evtll schon das Problem


  

Betrifft: AW: Makro Reiterverweismatrix von: Steffen
Geschrieben am: 05.09.2014 18:12:16

Danke Frank!

Die Befehle waren mir noch unbekannt - "programmiere" mit VBA auch erst seit kurzem.

Ich probiere es gleich aus:

Okay - ist etwas schneller aber nur minimal.

Habe eine Beispielexcel angefügt:
https://www.herber.de/bbs/user/92499.zip

Info: Die Suchprozedur ist hier das entscheidende Problem - ich rede hier von einer zu durchsuchenden Excel von über 10 MB Größe.


  

Betrifft: AW: Makro Reiterverweismatrix von: Steffen
Geschrieben am: 05.09.2014 18:36:20

FYI: Das Makro ist nach 23 Minuten durchgelaufen.


  

Betrifft: AW: Makro Reiterverweismatrix von: Franc
Geschrieben am: 06.09.2014 00:50:53

gut - ich hab das mal (komplett) umgeschrieben
wie immer gilt - das Original an nem anderen Ort speichern

Meine Testzeiten waren wie folgt.
1.000.000 Verweise in Blatt 3 (wollte nicht aufteilen, weils aufs gleich rauskommt und da du alle Werte ins Blatt einträgst, sollte er auch nicht viel mehr finden, weil dann das Ende der Spalte erreicht wird)

das Suchmakro hat dafür 136 Sekunden gebraucht (war aber schon optimiert)
das ganze mit der neuen Version dauerte nur noch 24 sek
sollte demnach mindestens 5x schneller sein (oder mehr)
darfst dann gern mal deine Zeiten posten ;-)

ich empfehle dir auch, erstmal das makro anzuschauen und die Kommentare zu lesen

die Formeln kann man sich sparen, weil direkt ausrechnen = Zeitersparnis
anstatt zu suchen wird nun der genutzte Bereich eingelesen und da verglichen - er vergleicht da zwar auch "leere" Zellen aber geht trotzdem schneller

hoffe ich hab deine Formeln richtig umgesetzt

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


  

Betrifft: AW: Makro Reiterverweismatrix von: Franc
Geschrieben am: 06.09.2014 00:58:42

hab grad gesehen das da noch 3 "Testzeilen" drinstehen ^^

a1 = arBereichFormel(i, j)
a2 = arSuche(k)
a3 = InStr(arBereichFormel(i, j), arSuche(k))

diese 3 kannste löschen
die dienten nur zu Fehlersuche, weil ich Depp ersetzen Funktion nutzte ohne nachzudenken und dann bei den Suchbegriffen ein leerzeichen drin war und der dann natürlich nichts mehr gefunden hat ^^


  

Betrifft: AW: Makro Reiterverweismatrix von: Steffen
Geschrieben am: 08.09.2014 11:52:48

Entschuldige die späte Antwort, brauchte ein freies Wochenende =)
So habe 2 Stunden gebraucht, um dein Makro zu 95% zu verstehen ;-)
Aber da ich es verstanden habe kann ich sagen: Klasse! Das hat mein Makro mal eben um Längen geschlagen!
Habe mir gerade ca. 20 deiner Befehle in mein Notizbüchlein geschrieben, für's weitere Leben zum nachschlagen! Top!
Mache mich jetzt ans Feintuning für "die große Mappe".

Eine Frage habe ich zu dem Makro:
If In Str(arBereichFormel(i, j), arSuche(k)) "größer als" 0 Then

...
arErgebnis(z, 5) = Mid(arBereichFormel(i, j), 2, InStrRev(arBereichFormel(i, j), "'") - 2)
arErgebnis(z, 6) = Right(arBereichFormel(i, j), Len(arBereichFormel(i, j)) - InStrRev(arBereichFormel(i, j), "'") - 1)
z = z + 1
das "Exit For" müsste man rausnehmen, falls mehrere Verweise in einer Zelle stehen

Exit For

End If


Da häufig mehrere Verweise in einer Zelle stehen (hab vergessen auch welche in der Beispielexcel zu nutzen) habe ich das Exit for auskommentiert, jedoch so, dass das Arraz folgendes speichert zu dem Wert:

Originalzelle: Reiter2!B10 = '3Reiter'!A1+'3Reiter'!C3 (Wert = 3)
Ausgegeben wird:
Cell: AI; Location: 2Reiter; Value: 3; Auf wen wird verlinkt: '3Reiter'!A1+'3Reiter Zelle: C3

Habe ich den Kommentar falsch verstanden und muss ich noch was dazu anpassen?


  

Betrifft: AW: Makro Reiterverweismatrix von: Steffen
Geschrieben am: 08.09.2014 11:19:25

Entschuldige die späte Antwort, brauchte ein freies Wochenende =)
So habe 2 Stunden gebraucht, um dein Makro zu 95% zu verstehen ;-)
Aber da ich es verstanden habe kann ich sagen: Klasse! Das hat mein Makro mal eben um Längen geschlagen!
Habe mir gerade ca. 20 deiner Befehle in mein Notizbüchlein geschrieben, für's weitere Leben zum nachschlagen! Top!
Mache mich jetzt ans Feintuning für "die große Mappe".

Eine Frage habe ich zu dem Makro:
If In Str(arBereichFormel(i, j), arSuche(k)) "größer als" 0 Then

...
arErgebnis(z, 5) = Mid(arBereichFormel(i, j), 2, InStrRev(arBereichFormel(i, j), "'") - 2)
arErgebnis(z, 6) = Right(arBereichFormel(i, j), Len(arBereichFormel(i, j)) - InStrRev(arBereichFormel(i, j), "'") - 1)
z = z + 1
das "Exit For" müsste man rausnehmen, falls mehrere Verweise in einer Zelle stehen

Exit For

End If


Da häufig mehrere Verweise in einer Zelle stehen (hab vergessen auch welche in der Beispielexcel zu nutzen) habe ich das Exit for auskommentiert, jedoch so, dass das Arraz folgendes speichert zu dem Wert:

Originalzelle: Reiter2!B10 = '3Reiter'!A1+'3Reiter'!C3 (Wert = 3)
Ausgegeben wird:
Cell: AI; Location: 2Reiter; Value: 3; Auf wen wird verlinkt: '3Reiter'!A1+'3Reiter Zelle: C3

Habe ich den Kommentar falsch verstanden und muss ich noch was dazu anpassen?


  

Betrifft: AW: Makro Reiterverweismatrix von: Steffen
Geschrieben am: 08.09.2014 14:54:37

Auch für alle anderen:

Die Suche hat Franc schon extrem gut optimiert (vor allem von der Geschwindigkeit).

Weiß jemand wie man den Fehler, dass bei einem Treffer, nicht nur der erste Verweis in einer Zelle ausgegeben wird, sondern auch die darauf folgenden?


  

Betrifft: AW: Makro Reiterverweismatrix von: Franc
Geschrieben am: 08.09.2014 18:05:03

nicht so schnell - muss auch arbeiten und kann das nur zu Hause machen ;-)

Wie sind denn die neuen Zeiten? (neugierig bin)
alt 23 Minuten
neu = schneller = ? ^^

war doch schwerer als gedacht und sicher umständlicher geschrieben als es sein müsste
Sachen sind in Subs, damit die Formatierung erhalten bleibt
füg das mal als neue Auswertung ein

den alten Teil

Sub alte_auswertung()

If InStr(arBereichFormel(i, j), arSuche(k)) > 0 Then
    ' wurde der Begriff gefunden, füllen wir das Array
    ' würde man das Ergebnis direkt eintragen würde es auch wieder ewig dauern
    arErgebnis(z, 1) = Replace(Cells(i, j).Address, "$", "")
    arErgebnis(z, 2) = Worksheets(a).Name
    arErgebnis(z, 3) = arBereichWert(i, j)
    arErgebnis(z, 5) = Mid(arBereichFormel(i, j), 2, InStrRev(arBereichFormel(i, j), "'") - 2)
    arErgebnis(z, 6) = Right(arBereichFormel(i, j), Len(arBereichFormel(i, j)) - InStrRev( _
arBereichFormel(i, j), "'") - 1)
    z = z + 1
    ' hier verlässt er die Suche und macht mit der nächsten "Zelle" weiter
    ' das "Exit For" müsste man rausnehmen, falls mehrere Verweise in einer Zelle stehen
    Exit For
End If

End Sub
gegen diesen hier (nicht das ganze Makro ersetzen) ^^

Sub neue_auswertung()


If InStr(arBereichFormel(i, j), arSuche(k)) > 0 Then
    ' wurde der Begriff gefunden, füllen wir das Array
    ' würde man das Ergebnis direkt eintragen würde es auch wieder ewig dauern
    m = 1
    Do
        ' erstes / nächstes Vorkommen von der Suche finden
        ' m bekommt den Wert von der gefundenen Stelle + Länge vom Suchwort
        ' m und n haben jetzt die Stelle wo der Zellverweis anfängt
        m = InStr(m, arBereichFormel(i, j), arSuche(k)) + Len(arSuche(k))
        ' brauchen wir weiter unten für den "Startpunkt"
        n = m
        Do
            m = m + 1
            'solang m um 1 erhöhen bis die aktuelle Stelle kein Buchstabe ist
            'das machen wir auch um das $ Zeichen für absolute Adressen einzubeziehen
        Loop While IsNumeric(Mid(arBereichFormel(i, j), m, 1)) = False
        
        Do
            'um paar Fehler zu umschiffen prüfen wir ob m kleiner der Länge von der Formel ist
            If m < Len(arBereichFormel(i, j)) Then m = m + 1
            'wenn die aktuelle Position eine Zahl ist nichts tun
            If Mid(arBereichFormel(i, j), m, 1) Like "#" Then
            Else
                'ist es keine Zahl dann m-1 und do loop verlassen (wollen ja nicht zu viel  _
haben)
                m = m - 1
                Exit Do
            End If
            'durchlaufen solang es eine Zahl ist und wir noch nicht am Ende der Formel sind
        Loop While IsNumeric(Mid(arBereichFormel(i, j), m, 1)) = True And m <> Len( _
arBereichFormel(i, j))
        'Ergebnisse eintragen
        'da wir bei A1 anfangen, können wir aus i und j die aktuelle Zelle in A1 Schreibweise  _
ermitteln
        arErgebnis(z, 1) = Replace(Cells(i, j).Address, "$", "")
        arErgebnis(z, 2) = Worksheets(a).Name
        arErgebnis(z, 3) = arBereichWert(i, j)
        'auf wen verwiesen wird nehmen wir von der Suche
        'da steht zum Beispiel 'Blatt'!
        'wir wolle es ab dem 2. Zeichen + Zeichenlänge = Anzahl Zeichen - 2x ' und 1x ! also 3
        arErgebnis(z, 5) = Mid(arSuche(k), 2, Len(arSuche(k)) - 3)
        'Die Zelle auf die verwiesen wird ist der Startpunkt n
        'länge = m - n + 1
        arErgebnis(z, 6) = Mid(arBereichFormel(i, j), n, m - n + 1)
        z = z + 1
        m = m - 1
        'solang wiederholen wie er das Suchwort nach dem aktuellen findet
    Loop While InStr(m, arBereichFormel(i, j), arSuche(k)) > 0
End If

End Sub



  

Betrifft: AW: Makro Reiterverweismatrix von: Steffen
Geschrieben am: 09.09.2014 10:40:20

Hey Franc,

kann Dir leider keine Auskunft über die Zeiten geben - habe es gerade erst (mit beiden Varianten) an der großen Mappe getestet, um jetzt ernüchterner Weise festzustellen, dass das Makro bei:

  ReDim arErgebnis(1 To lLetzteZeile * lLetzteSpalte, 1 To 6)
Sich aufhängt mit der Fehlermeldung: "Out of memory"
Laut google kann dies der allgemeine Speicher als auch RAM sein. Muss ich noch überprüfen.

Bei kleineren Mappen funktioniert die neue Version bei mir bis bei:
If InStr(arBereichFormel(i, j), arSuche(k)) > 0 Then
Wobei ich diesen Fehler mir zuordne, denn bei der großen Mappe ist das Makro ja "weiter" gekommen.

Ich gehe das Problem für heute von zwei Seiten an:
  • a) Out of memory - Lösung findet damit das Array nicht den Speicher sprengt

  • b) back to the roots: den Suchmechanismus unangetastet lassen und die Ausgabe in der 5. Zeile im Array spliten ("='2Reiter'!A1+Sheet3!B123*'3Reiter'!A2" in die jeweiligen Reiterausgaben (2Reiter / Sheet3 / 3Reiter


    • Mit Split / InStr(Rev) / Search wird es schwierig aufgrund der unterschiedlichen Formatierungen und Rechenzeichen.


      

    Betrifft: AW: Makro Reiterverweismatrix von: Franc
    Geschrieben am: 09.09.2014 13:19:21

    mal schnell zwischengefragt
    drück bei der großen Mappe auf strg + Ende und schreib welche Zelle das ist

    hast du etwas in dem Makro geändert?
    Wenn nein, dann sollte es keinen Fehler geben außer es existiert eines der beiden Arrays nicht mehr oder es gibt kein i,j oder k oder einer der genannten Variablen hat einen zu niedrigen (in dem Fall 0, weil beide mit 1 anfangen) oder einen höheren Wert als es Einträge im Array gibt.


      

    Betrifft: AW: Makro Reiterverweismatrix von: Steffen
    Geschrieben am: 09.09.2014 14:03:38

    Okay der erste Fehler war ein Flüchtigkeitsfehler - Copy+Paste soll gelernt sein.
    Habe das Makro durchlaufen lassen bei "Der Großen" und nach der Fehlermeldung auf "Debug" geklickt und in der Mappe dann Strg+End = XFC458 (gleich im ersten Reiter).

    Run-time error '7':

Out of memory
    Kann es sein, dass wir das Array zu "vollladen"?


      

    Betrifft: AW: Makro Reiterverweismatrix von: Franc
    Geschrieben am: 09.09.2014 14:29:57

    Stehen da wirklich noch Daten?
    Das würde bedeuten das da (fast) max. Spaltenanzahl = 16383 genutzt wird.
    Normal zeigt strg + Ende in einer Mappe (dazu muss man die einfach nur offen haben ohne Makros zu starten) die letzte benutze Zelle an. Im Normal ist das dann auch wirklich eine beutzte Zelle bzw. stand da dann schon mal was drin.

    Bis zu welcher Spalte gehen denn die Daten?

    Man kann das ganz aber auch anders lösen.


      

    Betrifft: AW: Makro Reiterverweismatrix von: Steffen
    Geschrieben am: 09.09.2014 15:23:50

    So bin jetzt mal die "kleine" der beiden Großen manuel durchgegangen (6MB).

    Das Maximum an beschriebenen Zellen in allen Worksheets an Zeilen liegt bei 950 und bei Spalten bei BJ (62. Spalte).

    Die Frage ist hier auch - kann man das dynamisch gestalten?

    Damit das Makro robust und für verschiedenste Mappen gestaltet werden kann.
    Ich messe das an der größeren der beiden Excelmappen. Als mein ursprüngliches Makro dort durchgelaufen ist (ca. 15 Stunden) lag es daran, dass Excel einfach abstürzte.

    Aber das lag eben auch an der extrem uneffizienten Mechanik des Suchlaufs.


      

    Betrifft: AW: Makro Reiterverweismatrix von: Steffen
    Geschrieben am: 09.09.2014 14:40:00

    Nebenbei die Verweisausgabe funktioniert nun einwandfrei.
    Habe es auch mit weiteren Trennzeichen probiert: " " & / ^ ;
    Das ist echt klasse!

    FYI:
    ReDim arErgebnis(1 To lLetzteZeile * lLetzteSpalte, 1 To 6)
    lLetzteZeile = 458
    lLetzteSpalte = 16383

    "You can use LONG columns to store a maximum of 16 KB or 16383 characters. "

    Denke mal dieser Speicher ist gemeint mit "Out of Memory"

    Kann man evtl. auch pro Sheet statt pro Workbook oder pro Zelle das Array ausgeben lassen, um das Array nicht zu überfüllen.

    Notiz zum vorherigen Beitrag:
    Zwar ist XFC458 die letzte Zelle des Bereiches - jedoch sind viele nicht beschrieben.


      

    Betrifft: AW: Makro Reiterverweismatrix von: Franc
    Geschrieben am: 09.09.2014 16:37:51

    jain - er meint das long ausreichend groß für die Zahl 16.363 ist.
    Byte hat zum Beispiel 1 Byte (und nicht KB ^^) = max. FF = max Anzahl von 255
    wenn ich jetzt zum Beispiel a as byte festlege und a 256 zuweise kommt die Fehlermeldung "Überlauf" = man muss ein größeren Datentyp wählen

    long = 4 Byte = FF FF FF FF = 4.294.967.295 aber 1 bit wird für +- reserviert.
    Glaub FF FF FF FF steht für -2.147.483.648 und FF FF FF FE für +2.147.483.647
    hoff das ist nicht falsch erklärt.

    Gibt auch Variablen die Kommawerte speichern können ect.
    http://de.wikibooks.org/wiki/VBA_in_Excel/_Variablen_und_Arrays

    out of memory heißt aber schlichtweg out of memory ^^
    In dem Fall geht deinem PC der Arbeitsspeicher aus. (er liest den Bereich auch 2x ein)
    Er will 458 * 16383 Zellen einlesen = 7.503.414 Zellen einlesen und das ganze 2x

    Um das trotzdem halbwegs dynamisch zu halten lösche die 2 Zeilen

    lLetzteZeile = Worksheets(a).UsedRange.SpecialCells(xlCellTypeLastCell).Row
    lLetzteSpalte = Worksheets(a).UsedRange.SpecialCells(xlCellTypeLastCell).Column

    und schreib dafür das rein - steht wieder in nem subwegen den Tabs

    das mit den Special cells grenzt das ganze erstmal wieder ein
    danach geht er jede Spalte durch und nimmt von der letzten Zeile im Blatt nach oben gesehen die erste befüllte Zeile ... man klingt das doof ^^
    das gleiche mit den Spalten
    Das ist so als wenn du nach ganze rechts gehen würdest (zu Beispiel Zeile 1, Spalte XFD und dann strg + linke Pfeiltaste drückst)
    er macht das für jede Spalte und merkt sich den größten Wert

    sollte jetzt bei Spalte immer noch 16.383 steht bzw. ein viel zu kleiner / großer Wert bedeutet das, das irgendwo in Spalte XFC oder links davon ein Wert vorhanden ist der da eigentlich nicht hingehört.
    Um evtll unsinnige Werte zu löschen kannst du auch manuell die Spalte Rechts von der letzten beschriebenen markieren (spalte ist nun komplett blau hinterlegt) und die Tastenkombi shift + strg + Pfeiltaste nach rechts drücken.
    nun sind alle Spalten rechts markiert und dann Rechtsklick aufs markierte - Zelle löschen.

    Bei sagen wir 100 Spalten x 1000 Zeilen sollte es keine Probleme geben. (sind ja "nur" 100.000 Zellen)

    Sub Zeile_spalte()

lLetzteZeile = 0
lLetzteSpalte = 0
For aktSpalte = 1 To Worksheets(a).UsedRange.SpecialCells(xlCellTypeLastCell).Column
    If Worksheets(a).Cells(Rows.Count, aktSpalte).End(xlUp).Row > lLetzteZeile Then
        lLetzteZeile = Worksheets(a).Cells(Rows.Count, aktSpalte).End(xlUp).Row
    End If
Next

For aktZeile = 1 To Worksheets(a).UsedRange.SpecialCells(xlCellTypeLastCell).Row
    If Worksheets(a).Cells(aktZeile, Columns.Count).End(xlToLeft).Column > lLetzteSpalte Then
        lLetzteSpalte = Worksheets(a).Cells(aktZeile, Columns.Count).End(xlToLeft).Column
    End If
Next

End Sub



      

    Betrifft: AW: Makro Reiterverweismatrix von: Steffen
    Geschrieben am: 09.09.2014 18:07:33

    Danke Franc für die ganze Mühe die du Dir machst!

    Werde morgen das Ganze ausprobieren - heute "schiebe ich eine ruhige Kugel"

    Billard


      

    Betrifft: AW: Makro Reiterverweismatrix von: Franc
    Geschrieben am: 09.09.2014 18:13:17

    gut - schreib bei Erfolg auch bitte die Zeiten rein. ;-)


      

    Betrifft: AW: Makro Reiterverweismatrix von: Steffen
    Geschrieben am: 10.09.2014 12:02:26

    Hallo Franc,

    so frisch und erholt nochmal ans Werk und nochmal 2 Bugs gefunden, ABER:
    Konnte Sie soweit lösen.
    FYI:
    Habe im Reiter SheetSearchList den Befehl

    Sub Test()
        .Cells(i - 1, 1) = "'" & Worksheets(i).Name & "'!"
        arSuche(i - 2) = "'" & Worksheets(i).Name & "!'" ' Suchbegriffe eintragen
End Sub
    umgewandet. Ich musste die ' und ! entfernen, da bei einem Reiter ohne Sonderzeichen am Anfang (z.B.: Sheet3 diese nicht eingefügt werden müssen, dass Makro aber so nach 'Sheet3'! sucht.

    Dementsprechend habe ich auch die Ausgabe angepasst
    Sub Ergebnis
         arErgebnis(z, 5) = Mid(arSuche(k), 2, Len(arSuche(k))-3)
End Sub

    da kein ' am Anfang und '! am Ende steht.

    Das selbe muss ich noch für das Ergebnis in der 6. Spalte des Arrays anpassen. Das wird schwierig da die Reiter unterschiedlich lang sind.

    Jetzt kommt das worauf wir alle gewartet haben - der große Test: (ja ich schreibe in Echtzeit)
    Das Makro läuft 10,7 Sekunden, schreibt dabei 4091 Treffer auf und durchsucht 20 Reiter.
    Beendet wird das Makro durch ein:
    Subscript out of Range in der Zeile: arErgebnis(z, 1) = Replace(Cells(i, j).Address, "$", "")
    z = 3751
    Ich denke bei z und dem Array muss der Fehler liegen.

    Die Zelle/Formel/usw. habe ich soweit nach Bugs untersucht:
    m = 229 in: 'Steffen Sheep'!$E$28
    n = 223 in: 'Steffen Sheep'!$E$28

    i = 29
    j = 1
    Die Formel in U29, die gerade durchsucht wir ist:(Reiter umbenannt, jedoch Zeichenanzahl für jeden Reiter identisch)
    k = 5
    arSuche(k) = "Steffen Sheep"
    Sub Formel
='Arzt Afterhour AH, @m'!U29*'Steffen Sheep'!$E$24+'Absturz Aasfresser'!U29*'Steffen Sheep'!$E$ _
25
+'Aufrisszone Umgangsform'!U29*'Steffen Sheep'!$E$26+Afterhour!U29*'Steffen Sheep'!$E$27+'Bus  _
Umgangsform'!U29
*'Steffen Sheep'!$E$28+Augenpflege!U29*'Steffen Sheep'!$E$29+'Auto Umgangsform'!U29*'Steffen  _
Sheep'!$E$30
+'Umgangsall Meppen 1'!U29*'Steffen Sheep'!$E$33+'ABC Umgangsform'!U29*'Steffen Sheep'!$E$31
+'Aerztin Steppen Umgangsform'!U29*'Steffen Sheep'!$E$32+'Umgangsall Meppen 2'!U29*'Steffen  _
Sheep'!$E$34
+'Umgangsall Meppen 3'!U29*'Steffen Sheep'!$E$35+'Umgangsall Meppen 4'!U29*'Steffen Sheep'!$E$ _
36
End Sub
    Info: Die Zellen links von dieser beinhalten die selbe Formel mit verschobenen Verweisen, dort jedoch anscheinend kein Fehler.


      

    Betrifft: AW: Makro Reiterverweismatrix von: Franc
    Geschrieben am: 10.09.2014 17:10:39

    Hmm - könnte mir grad nicht erklären, warum er grad an der Stelle diese Fehler bringt.
    Wäre z höher als die Anzahl möglicher Einträge würde es ein Überlauffehler geben.

    die Zeile selbst macht nur folgendes

    Replace(Cells(i, j).Address, "$", "")

    cells(i = 1, j = 29).Address =$A$29 und durch das Replace wird das zu A29
    Das wird dann dem Array arErgebnis(z=3751, 1) zugewiesen
    Das kann eigentlich gar nicht auf Fehler laufen.

    Hast du im Editor unten die "Lokal" Ansicht? Wenn nein aktiviere sie unter "Ansicht" - "Lokal"
    Wenn er an der Stelle stoppt siehst du unten alle Variablen aus dem Modul (aber keine globalen Variablen - falls du was ergänzt hat)
    klick bei arErgebnis auf das "+" zeichen und scrolle mal runter und schau nach ob der entsprechende Eintrag vefügbar ist.

    Test auch mal ob der Fehler auftritt, wenn du
    arErgebnis(z, 5) = arErgebnis(z, 1) = Replace(Cells(i, j).Address, "$", "")
    durch
    xyz = Replace(Cells(i, j).Address, "$", "")
    ersetzt. (dann fehlt zwar im Blatt erstmal eine Angabe aber nur mal so zum schauen.)

    Kann auch an was anderem liegen aber dazu solltest du noch mal das gesamte Makro posten wie es bei dir aktuell in der Mappe steht.


      

    Betrifft: AW: Makro Reiterverweismatrix von: Steffen
    Geschrieben am: 10.09.2014 18:51:28

    arErgebnis für z=3751 ist nicht vorhanden.
    Für 3750:
    arErgebnis(3750,1/2/3/4/5/6) = U29/Reiter/0/Empty/"Steffen Sheep"/"!$E$27"

    Habe:
    arErgebnis(z, 1) = ... & arErgebnis(z, 5) = ...
    durch
    xyz = Replace(Cells(i, j).Address, "$", "")
    ersetzt.
    Selber Fehler bei
    arErgebnis(z, 2) = Worksheets(a).Name (und auch kein Eintrag im Local)

    Nochmal das gesamte Skript (habe eig. nur das Speichern abgeändert):

     Sub Hirn2()

Dim a As Integer, i As Long, j As Long, k As Integer, z As Long, gespeichert As Integer
Dim arBereichFormel As Variant, arBereichWert As Variant, arSuche As Variant, arErgebnis As  _
Variant
Dim strBereich As String, lLetzteZeile As Long, lLetzteSpalte As Long, strFilename As String

' Speicherdialog
    Application.DisplayAlerts = False
   ChDrive "c:\temp\"
    strFilename = "SheetLinksMatrixOverview" & Format(Date, "yyyymmdd") & ".xlsx"
    Application.Dialogs(xlDialogSaveAs).Show (strFilename)
    Application.DisplayAlerts = False
    strFilename = ActiveWorkbook.Name


Application.Calculation = xlCalculationManual ' automat. Berechnung ausschalten
Application.ScreenUpdating = False ' Bildschirmaktualisierung ausschalten

Application.DisplayAlerts = False ' er fragt nicht nach beim löschen der Blätter
For i = Worksheets.Count To 1 Step -1
    Worksheets(i).Visible = xlSheetVisible
    If Worksheets(i).Name = "SheetMatrixOverview" Then Worksheets(i).Delete
    If Worksheets(i).Name = "SheetSearchList" Then Worksheets(i).Delete
Next
Application.DisplayAlerts = True

' suche dimensionieren = Anzahl Tabellenblätter (aktuell ja noch ohne die 2 ersten)
ReDim arSuche(1 To Worksheets.Count)

' Blätter hinzufügen
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "SheetMatrixOverview"
Worksheets.Add after:=Worksheets(1)
ActiveSheet.Name = "SheetSearchList"

' Blatt formatieren
With Worksheets("SheetSearchList")
    .Cells(1, 1) = "Suchbegriffe:"
    .Cells(1, 3) = "Cell:"
    .Cells(1, 4) = "Location:"
    .Cells(1, 5) = "Value:"
    .Cells(1, 7) = "Auf wen wird verlinkt:"
    
    For i = 3 To Worksheets.Count ' vom 3. bis letzten Blatt
        .Cells(i - 1, 1) = Worksheets(i).Name
        arSuche(i - 2) = Worksheets(i).Name ' Suchbegriffe eintragen
    Next
End With

For a = 3 To Worksheets.Count ' vom 3. bis letzten Blatt
    z = 1 ' z ist für das Ergebnisarray
    Worksheets(a).Activate ' das muss aktiv sein, weil sonst weiter unten keine Formeln  _
eingelesen werden
                    lLetzteZeile = 0
                    lLetzteSpalte = 0
                    For aktSpalte = 1 To Worksheets(a).UsedRange.SpecialCells( _
xlCellTypeLastCell).Column
                        If Worksheets(a).Cells(Rows.Count, aktSpalte).End(xlUp).Row >  _
lLetzteZeile Then
                            lLetzteZeile = Worksheets(a).Cells(Rows.Count, aktSpalte).End(xlUp). _
Row
                        End If
                    Next
        
                    For aktZeile = 1 To Worksheets(a).UsedRange.SpecialCells(xlCellTypeLastCell) _
.Row
                        If Worksheets(a).Cells(aktZeile, Columns.Count).End(xlToLeft).Column >  _
lLetzteSpalte Then
                            lLetzteSpalte = Worksheets(a).Cells(aktZeile, Columns.Count).End( _
xlToLeft).Column
                        End If
                    Next
    ' Geht immer von A1 bis letzte Zelle
    strBereich = "$A$1:" & Worksheets(a).UsedRange.SpecialCells(xlCellTypeLastCell).Address
    ' falls keine oder nur eine beschrieben sind geben wir ihm die ersten 2 vor
    ' tun wir das nicht, läuft es auf Fehler, weil das Array nicht befüllt wird
    If lLetzteSpalte = 1 And lLetzteZeile = 1 Then strBereich = "A1:B2"
    
    ' hier kommen 2 Arrays vom genutzten Bereich
    ' die Formeln
    arBereichFormel = range(strBereich).Formula
    ' die Werte die drin stehen
    arBereichWert = range(strBereich)
    ' Ergebnis Array anpassen, Anzahl Einträge = Letzte Zeile * letzte Spalte und das Array hat  _
6 "Spalten"
    ReDim arErgebnis(1 To lLetzteZeile * lLetzteSpalte, 1 To 6)
    
    ' jetzt schaut er in jeden Eintrag vom Array nach
    For i = 1 To lLetzteZeile
        For j = 1 To lLetzteSpalte
            ' prüfen ob es eine Formel ist (spart Zeit wenn nicht)
            If InStr(arBereichFormel(i, j), "=") > 0 Then
                ' schauen ob der Suchbegriff vorkommt - dazu prüft er direkt jeden Suchbegriff
                For k = 1 To UBound(arSuche) ' ubound = Nr. vom letzten Eintrag
                    If InStr(arBereichFormel(i, j), arSuche(k)) > 0 Then
                        ' wurde der Begriff gefunden, füllen wir das Array
                        ' würde man das Ergebnis direkt eintragen würde es auch wieder ewig  _
dauern
                        m = 1
                        Do
                            ' erstes / nächstes Vorkommen von der Suche finden
                            ' m bekommt den Wert von der gefundenen Stelle + Länge vom Suchwort
                            ' m und n haben jetzt die Stelle wo der Zellverweis anfängt
                            m = InStr(m, arBereichFormel(i, j), arSuche(k)) + Len(arSuche(k))
                            ' brauchen wir weiter unten für den "Startpunkt"
                            n = m
                            Do
                                m = m + 1
                                'solang m um 1 erhöhen bis die aktuelle Stelle kein Buchstabe  _
ist
                                'das machen wir auch um das $ Zeichen für absolute Adressen  _
einzubeziehen
                            Loop While IsNumeric(Mid(arBereichFormel(i, j), m, 1)) = False
                            
                            Do
                                'um paar Fehler zu umschiffen prüfen wir ob m kleiner der Länge  _
von der Formel ist
                                If m < Len(arBereichFormel(i, j)) Then m = m + 1
                                'wenn die aktuelle Position eine Zahl ist nichts tun
                                If Mid(arBereichFormel(i, j), m, 1) Like "#" Then
                                Else
                                    'ist es keine Zahl dann m-1 und do loop verlassen (wollen  _
ja nicht zu viel _
                    haben)
                                    m = m - 1
                                    Exit Do
                                End If
                                'durchlaufen solang es eine Zahl ist und wir noch nicht am Ende  _
der Formel sind
                            Loop While IsNumeric(Mid(arBereichFormel(i, j), m, 1)) = True And m  _
<> Len( _
                    arBereichFormel(i, j))
                            'Ergebnisse eintragen
                            'da wir bei A1 anfangen, können wir aus i und j die aktuelle Zelle  _
in A1 Schreibweise _
                    ermitteln
                            xyz = Replace(Cells(i, j).Address, "$", "")
                            arErgebnis(z, 2) = Worksheets(a).Name
                            arErgebnis(z, 3) = arBereichWert(i, j)
                            'auf wen verwiesen wird nehmen wir von der Suche
                            'da steht zum Beispiel 'Blatt'!
                            'wir wolle es ab dem 2. Zeichen + Zeichenlänge = Anzahl Zeichen -  _
2x ' und 1x ! also 3
                            xyz = Replace(Cells(i, j).Address, "$", "")
                            'Die Zelle auf die verwiesen wird ist der Startpunkt n
                            'länge = m - n + 1
                            arErgebnis(z, 6) = Mid(arBereichFormel(i, j), n, m - n + 1)
                            z = z + 1
                            m = m - 1
                            'solang wiederholen wie er das Suchwort nach dem aktuellen findet
                        Loop While InStr(m, arBereichFormel(i, j), arSuche(k)) > 0
                    End If

                Next
            End If
        Next
    Next
    ' er hats das Blatt durchgeackert und wenn mindestens 1 Ergebnis vorliegt, trägt er es ein
    If z <> 1 Then
        ' nächste freie Zeile suchen
        lLetzteZeile = Sheets("SheetSearchList").Cells(Rows.Count, 3).End(xlUp).Row + 1
        ' das gesamte Array ins Blatt eintragen
        Worksheets("SheetSearchList").Cells(lLetzteZeile, 3).Resize(z - 1, 6).Value =  _
arErgebnis
    End If
    ' wiederholen bis alle Blätter durch sind
Next

' arrays löschen
Erase arBereichFormel
Erase arBereichWert
Erase arErgebnis

' 1. Blatt aktivieren
Sheets("SheetMatrixOverview").Activate
Cells(1, 1).Value = "Matrix:"

For i = 3 To Worksheets.Count
    Cells(i - 1, 1).Value = Worksheets(i).Name
    Cells(1, i - 1).Value = Worksheets(i).Name
Next

' wir berechnen das direkt in VBA ohne Umweg
lLetzteZeile = Sheets("SheetSearchList").Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To Worksheets.Count
    For j = 3 To Worksheets.Count
        Cells(i - 1, j - 1).Value = Application.WorksheetFunction.CountIfs(Sheets(" _
SheetSearchList").range("D2:D" & lLetzteZeile), Worksheets(i).Name, Sheets("SheetSearchList").range("G2:G" & lLetzteZeile), Worksheets(j).Name)
    Next
Next

' alles wieder einschalten
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Exit Sub

Error:
Erase arBereichFormel
Erase arBereichWert
Erase arErgebnis
Application.Calculation = xlCalculationAutomatic ' automat.Berechnung einschalten falls ein  _
Fehler ausgegeben wird
MsgBox ("Error 404 - Page not Found")

End Sub
    Local Eintrag:
    a = 21; i = 29; j = 21; k = 4; z= 3751; gespeichert = 0; strBereich "$A$1:$AE$322"; lLetzteZeile = 125; lLetzteSpalte = 30; aktSpalte = 32; aktZeile = 323; m = 229; 2 = 223; xyz = "U29"


      

    Betrifft: AW: Makro Reiterverweismatrix von: Franc
    Geschrieben am: 11.09.2014 16:34:20

    omg - seh wieder den Wald vor lauter Bäumen nicht ^^
    müsste damit gehen und bin dann mal auf finalen Benchmark gespannt. ^^
    grad wollte ich erklären warum z nicht zu klein sein kann und ja ... natürlich kann z zu klein werden, weil wenn im Schnitt in jeder Zelle mehr als ein Verweis steht dann wird z zu klein. (ich war gedanklich immer noch beim Schema wo eine Zelle nur 1 Wert liefern kann

    nimm mal das
    ReDim arErgebnis(1 To lLetzteZeile * lLetzteSpalte * 10, 1 To 6)
    dann wäre Platz für (aktuelles Beispiel)
    lLetzteSpalte = 30 * lLetzteZeile = 125 * 10 = 37.500 Einträge
    Das sollte vollkommen langen, wir verschwenden nicht zu viel Platz und ersparen und redim preserve Orgien. Wirst ja kaum im Schnitt mehr als 10 Verweise pro Zelle haben.

    Ergänze auch folgende Zeile.
    Die kommt nach den 2 for Schleifen und vor diese Zeile (NICHT ersetzen ^^)
    "If InStr(arBereichFormel(i, j), "=") "kleiner" 0 Then"

    arBereichFormel(i, j) = Replace(Replace(arBereichFormel(i, j), "'", ""), "!", "")
    Damit ersetzt er etwaige ' und ! in er Formel durch nichts und es sollte keine Probleme dabei geben den Bereich zu ermittel worauf verwiesen wird.
    Das Sucharray selbst wird ja so oder so nur mit den Blattnamen ohne ' oder ! befüllt.
    Die Änderungen finden auch nur im Array statt und haben keine Auswirkung auf das Arbeitsblatt.


    Mir fällt noch folgendes auf
    strg + Ende führt bei dir wahrscheinlich bei dem Blatt zur Zelle AF323 obwohl das eigentlich AD125 sein müsste.Evtll mal den Rest"löschen"?
    Rechts neben die letzte benutzte Spalte zum Beispiel AG1 klicken, strg + shift + ende gefolgt von rechtsklick, Zellen löschen, ganze Spalte löschen
    und dann noch mal in A126? und da auch strg + shift + ende, zellen löschen, ganze Zeile löschen
    Mappe speichern, schließen, neu öffnen und dann solltestrg + ende AD125 sein. (wenn sich bis dahin nichts ändert ^^)


      

    Betrifft: AW: Makro Reiterverweismatrix von: Steffen
    Geschrieben am: 12.09.2014 18:35:08

    Hallo Franc,
    ein weiteres DANKE FRANC, wir sind wieder ein großes Stück weiter gekommen.
    wir haben unser Ergebnis versechsfacht in 18,9 Sekunden haben wir 23809 Treffer eingetragen.
    WOHOO!! ERFOLG!
    (im Array sind laut LocalView jetzt 24380 Treffer - Aber komischerweise sind viele davon einfach Empty - ab dem 600.)

    Fehler tritt auf: Out of Memory
    arBereichFormel = range(strBereich).Formula
    range(strBereich).Formula =
    strBereich ist "$A$1:$XFC$942 (also wieder unser strg + ende Problem)


    a 26
    i 54
    j 47
    k 73
    z 1
    lLetzteZeile 942, lLetzteSpalte 48
    aktSpalte 16384
    aktZeile 943
    m 22
    n 18
    länge 6

    Lösungsversuche:
    1. Überflüssige Spalten löschen, von WErten und Formaten "befreien"
    2. "Freeze Panes" (Deutsch soetwas wie: eingefrorene Bereiche) "auftauen" ;-)
    gespeichert und neugestartet
    Seitdem immer Makroabsturz.
    1. Habe alle 72 (ist k = 73 so richtig, da die erste Zeile mit: Suchbegriffe mitgezähltz wird?)Reiter nach Ihren maximalen Spalten und Zeilen durchforstet und diese dann manuel eingegeben.
    Das Makro läuft dann (da nicht dynamisch) ca 15 Minuten und gibt eine Fehlermeldung aus, die jedoch dank sofortigem Absturz nicht lesbar ist. (Strg + Pause bewirkt das selbe)

    Weiterhin aufgetretener Fehler:
    In Zeilen mit 'Reiter'!#REF durchsucht das Makro bis zu locker 10000000 Stellen nach dem Beginn der nächsten Adresse. Bei einer Formel die nichtmal so lang ist (=IFERROR(AE12/'Surf Dezember AH, %?'!#REF!;"N/M").

    Hier nochmal das Makro auf dem neusten Stand:

    Sub Hirn3()

Dim a As Integer, i As Long, j As Long, k As Integer, z As Long, gespeichert As Integer
Dim arBereichFormel As Variant, arBereichWert As Variant, arSuche As Variant, arErgebnis As  _
Variant
Dim strBereich As String, lLetzteZeile As Long, lLetzteSpalte As Long, strFilename As String

' Speicherdialog
    Application.DisplayAlerts = False
   ChDrive "c:\temp\"
    strFilename = "SheetLinksMatrixOverview" & Format(Date, "yyyymmdd") & ".xlsx"
    Application.Dialogs(xlDialogSaveAs).Show (strFilename)
    Application.DisplayAlerts = False
    strFilename = ActiveWorkbook.Name


Application.Calculation = xlCalculationManual ' automat. Berechnung ausschalten
Application.ScreenUpdating = False ' Bildschirmaktualisierung ausschalten

Application.DisplayAlerts = False ' er fragt nicht nach beim löschen der Blätter
For i = Worksheets.Count To 1 Step -1
    Worksheets(i).Visible = xlSheetVisible
    If Worksheets(i).Name = "SheetMatrixOverview" Then Worksheets(i).Delete
    If Worksheets(i).Name = "SheetSearchList" Then Worksheets(i).Delete
Next
Application.DisplayAlerts = True

' suche dimensionieren = Anzahl Tabellenblätter (aktuell ja noch ohne die 2 ersten)
ReDim arSuche(1 To Worksheets.Count)

' Blätter hinzufügen
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "SheetMatrixOverview"
Worksheets.Add after:=Worksheets(1)
ActiveSheet.Name = "SheetSearchList"

' Blatt formatieren
With Worksheets("SheetSearchList")
    .Cells(1, 1) = "Suchbegriffe:"
    .Cells(1, 3) = "Cell:"
    .Cells(1, 4) = "Location:"
    .Cells(1, 5) = "Value:"
    .Cells(1, 7) = "Auf wen wird verlinkt:"
    
    For i = 3 To Worksheets.Count ' vom 3. bis letzten Blatt
        .Cells(i - 1, 1) = Worksheets(i).Name
        arSuche(i - 2) = Worksheets(i).Name ' Suchbegriffe eintragen
    Next
End With

For a = 3 To Worksheets.Count ' vom 3. bis letzten Blatt
    z = 1 ' z ist für das Ergebnisarray
    Worksheets(a).Activate ' das muss aktiv sein, weil sonst weiter unten keine Formeln  _
eingelesen werden
                    lLetzteZeile = 0
                    lLetzteSpalte = 0
                    For aktSpalte = 1 To Worksheets(a).UsedRange.SpecialCells( _
xlCellTypeLastCell).Column
                        If Worksheets(a).Cells(Rows.Count, aktSpalte).End(xlUp).Row >  _
lLetzteZeile Then
                            lLetzteZeile = Worksheets(a).Cells(Rows.Count, aktSpalte).End(xlUp). _
Row
                        End If
                    Next
        
                    For aktZeile = 1 To Worksheets(a).UsedRange.SpecialCells(xlCellTypeLastCell) _
.Row
                        If Worksheets(a).Cells(aktZeile, Columns.Count).End(xlToLeft).Column >  _
lLetzteSpalte Then
                            lLetzteSpalte = Worksheets(a).Cells(aktZeile, Columns.Count).End( _
xlToLeft).Column
                        End If
                    Next
    ' Geht immer von A1 bis letzte Zelle
    strBereich = "$A$1:" & Worksheets(a).UsedRange.SpecialCells(xlCellTypeLastCell).Address
    ' falls keine oder nur eine beschrieben sind geben wir ihm die ersten 2 vor
    ' tun wir das nicht, läuft es auf Fehler, weil das Array nicht befüllt wird
    If lLetzteSpalte = 1 And lLetzteZeile = 1 Then strBereich = "A1:B2"
    
    ' hier kommen 2 Arrays vom genutzten Bereich
    ' die Formeln
    arBereichFormel = range(strBereich).Formula
    ' die Werte die drin stehen
    arBereichWert = range(strBereich)
    ' Ergebnis Array anpassen, Anzahl Einträge = Letzte Zeile * letzte Spalte und das Array hat  _
6 "Spalten"
    ReDim arErgebnis(1 To lLetzteZeile * lLetzteSpalte * 10, 1 To 6) ' 10 = durschnittliche  _
Verweise pro Zelle als Kennzahl für die Speicherkapatität des Arrays
    
    ' jetzt schaut er in jeden Eintrag vom Array nach
    For i = 1 To lLetzteZeile
        For j = 1 To lLetzteSpalte
            arBereichFormel(i, j) = Replace(Replace(arBereichFormel(i, j), "'", ""), "!", "")
            ' prüfen ob es eine Formel ist (spart Zeit wenn nicht)
            If InStr(arBereichFormel(i, j), "=") > 0 Then
                ' schauen ob der Suchbegriff vorkommt - dazu prüft er direkt jeden Suchbegriff
                For k = 1 To UBound(arSuche) ' ubound = Nr. vom letzten Eintrag
                    If InStr(arBereichFormel(i, j), arSuche(k)) > 0 Then
                        ' wurde der Begriff gefunden, füllen wir das Array
                        ' würde man das Ergebnis direkt eintragen würde es auch wieder ewig  _
dauern
                        m = 1
                        Do
                            ' erstes / nächstes Vorkommen von der Suche finden
                            ' m bekommt den Wert von der gefundenen Stelle + Länge vom Suchwort
                            ' m und n haben jetzt die Stelle wo der Zellverweis anfängt
                            m = InStr(m, arBereichFormel(i, j), arSuche(k)) + Len(arSuche(k))
                            ' brauchen wir weiter unten für den "Startpunkt"
                            n = m
                            Do
                                m = m + 1
                                'solang m um 1 erhöhen bis die aktuelle Stelle kein Buchstabe  _
ist
                                'das machen wir auch um das $ Zeichen für absolute Adressen  _
einzubeziehen
                            Loop While IsNumeric(Mid(arBereichFormel(i, j), m, 1)) = False
                            
                            Do
                                'um paar Fehler zu umschiffen prüfen wir ob m kleiner der Länge  _
von der Formel ist
                                If m < Len(arBereichFormel(i, j)) Then m = m + 1
                                'wenn die aktuelle Position eine Zahl ist nichts tun
                                If Mid(arBereichFormel(i, j), m, 1) Like "#" Then
                                Else
                                    'ist es keine Zahl dann m-1 und do loop verlassen (wollen  _
ja nicht zu viel _
                    haben)
                                    m = m - 1
                                    Exit Do
                                End If
                                'durchlaufen solang es eine Zahl ist und wir noch nicht am Ende  _
der Formel sind
                            Loop While IsNumeric(Mid(arBereichFormel(i, j), m, 1)) = True And m  _
<> Len( _
                    arBereichFormel(i, j))
                            'Ergebnisse eintragen
                            'da wir bei A1 anfangen, können wir aus i und j die aktuelle Zelle  _
in A1 Schreibweise _
                    ermitteln
                            'On Error GoTo Fehler
                            arErgebnis(z, 1) = Replace(Cells(i, j).Address, "$", "")
                            arErgebnis(z, 2) = Worksheets(a).Name
                            arErgebnis(z, 3) = arBereichWert(i, j)
                            'auf wen verwiesen wird nehmen wir von der Suche
                            'da steht zum Beispiel 'Blatt'!
                            'wir wolle es ab dem 2. Zeichen + Zeichenlänge = Anzahl Zeichen -  _
2x ' und 1x ! also 3
                            arErgebnis(z, 5) = Mid(arSuche(k), 1, Len(arSuche(k)) - 1)
                            'Die Zelle auf die verwiesen wird ist der Startpunkt n
                            länge = m - n + 1
                            arErgebnis(z, 6) = Mid(arBereichFormel(i, j), n, m - n + 1)
'Fehler:
                            z = z + 1
                            m = m - 1
                            'solang wiederholen wie er das Suchwort nach dem aktuellen findet
                        Loop While InStr(m, arBereichFormel(i, j), arSuche(k)) > 0
                    End If

                Next
            End If
        Next
    Next
    ' er hats das Blatt durchgeackert und wenn mindestens 1 Ergebnis vorliegt, trägt er es ein
    If z <> 1 Then
        ' nächste freie Zeile suchen
        lLetzteZeile = Sheets("SheetSearchList").Cells(Rows.Count, 3).End(xlUp).Row + 1
        ' das gesamte Array ins Blatt eintragen
        Worksheets("SheetSearchList").Cells(lLetzteZeile, 3).Resize(z - 1, 6).Value =  _
arErgebnis
    End If
    ' wiederholen bis alle Blätter durch sind
Next

' arrays löschen
Erase arBereichFormel
Erase arBereichWert
Erase arErgebnis

' 1. Blatt aktivieren
Sheets("SheetMatrixOverview").Activate
Cells(1, 1).Value = "Matrix:"

For i = 3 To Worksheets.Count
    Cells(i - 1, 1).Value = Worksheets(i).Name
    Cells(1, i - 1).Value = Worksheets(i).Name
Next

' wir berechnen das direkt in VBA ohne Umweg
lLetzteZeile = Sheets("SheetSearchList").Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To Worksheets.Count
    For j = 3 To Worksheets.Count
        Cells(i - 1, j - 1).Value = Application.WorksheetFunction.CountIfs(Sheets(" _
SheetSearchList").range("D2:D" & lLetzteZeile), Worksheets(i).Name, Sheets("SheetSearchList").range("G2:G" & lLetzteZeile), Worksheets(j).Name)
    Next
Next

' alles wieder einschalten
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Exit Sub

Error:
Erase arBereichFormel
Erase arBereichWert
Erase arErgebnis
Application.Calculation = xlCalculationAutomatic ' automat.Berechnung einschalten falls ein  _
Fehler ausgegeben wird
MsgBox ("Error 404 - Page not Found")

End Sub
    Info:
    Kann Dir am Wochenende leider nicht sicher antworten, da ich in eine neue Wohnung ohne Internetzugang ziehe.
    Versuche aber anderweitig weiterhin auf dem laufenden sein zu können.

    Ich hoffe du bist dieses Makros noch nicht überdrüssig sondern freust dich über jeden weiteren Wert der ausgegeben wird, denn ich werde nicht aufgeben, weil es mein Speicher tut!


      

    Betrifft: AW: Makro Reiterverweismatrix von: Steffen
    Geschrieben am: 16.09.2014 19:34:09

    So es gibt neue Ergebnisse:

    Die kleinere Mappe rattert er durch in ca. 50 Sekunden trägt das Makro 30830 Werte ein und erstellt dazu die Matrix.

    Behobene Fehler: Manuelles Rauslöschen des Strg + Ende Berereiches der bis XFC oder zurr maximalen Zeile ging. Der Fehler, dass danach das Makro sich aufhing lag daran, dass ein neuer Bug eine unendlich Schleife erzeugte durch eine Zelle mit dem Inhalt: ='Reiter'!#Ref da die Loop Isnumeric bis zur maximalen Stelle innerhalb der Zelle suchte (nebenbei: 1073741825).

    Durch ein eingefügtes
    If m > Länge der Zelle Exit Do
    ließ sich dies beheben.

    Jetzt bearbeite ich die Bugs an der großen Mappe und hoffe auf weitere Werte.
    Bug:
    Zelle mit einem Kommentar: '=-12,8 (Reiter2) -69,0(ABC) - 999,9 (ABC3)
    Die Suchengine findet den Reiter "Reiter2". Kann jedoch den Rest nicht zuordnen.
    Fehlermeldung: Application-defined or object-defined error

    Problem:
    a 12; i 224; j 46; k 190, z 695; lLetzteZeile 8471; lLetzteSpalte 45; aktSpalte 46; aktZeile 243; m 79; n 75; länge 6
    arSuche = Subscript out of Range (k=190 - bei 189 Reitern)
    arBereichFormel = Subscript out of Range
    strBereich $A$1:$AS$242
    arErgebnis = empty



    Hier der aktuelle Code:

    Sub Hirn2()

Dim a As Integer, i As Long, j As Long, k As Integer, z As Long, gespeichert As Integer
Dim arBereichFormel As Variant, arBereichWert As Variant, arSuche As Variant, arErgebnis As  _
Variant
Dim strBereich As String, lLetzteZeile As Long, lLetzteSpalte As Long, strFilename As String

' Speicherdialog
    Application.DisplayAlerts = False
   ChDrive "c:\temp\"
    strFilename = "SheetLinksMatrixOverview" & Format(Date, "yyyymmdd") & ".xlsx"
    Application.Dialogs(xlDialogSaveAs).Show (strFilename)
    Application.DisplayAlerts = False
    strFilename = ActiveWorkbook.Name


Application.Calculation = xlCalculationManual ' automat. Berechnung ausschalten
Application.ScreenUpdating = False ' Bildschirmaktualisierung ausschalten

Application.DisplayAlerts = False ' er fragt nicht nach beim löschen der Blätter
For i = Worksheets.Count To 1 Step -1
    Worksheets(i).Visible = xlSheetVisible
    If Worksheets(i).Name = "SheetMatrixOverview" Then Worksheets(i).Delete
    If Worksheets(i).Name = "SheetSearchList" Then Worksheets(i).Delete
Next
Application.DisplayAlerts = True

' suche dimensionieren = Anzahl Tabellenblätter (aktuell ja noch ohne die 2 ersten)
ReDim arSuche(1 To Worksheets.Count)

' Blätter hinzufügen
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "SheetMatrixOverview"
Worksheets.Add after:=Worksheets(1)
ActiveSheet.Name = "SheetSearchList"

' Blatt formatieren
With Worksheets("SheetSearchList")
    .Cells(1, 1) = "Suchbegriffe:"
    .Cells(1, 3) = "Cell:"
    .Cells(1, 4) = "Location:"
    .Cells(1, 5) = "Value:"
    .Cells(1, 7) = "Auf wen wird verlinkt:"
    
    For i = 3 To Worksheets.Count ' vom 3. bis letzten Blatt
        .Cells(i - 1, 1) = Worksheets(i).Name
        arSuche(i - 2) = Worksheets(i).Name ' Suchbegriffe eintragen
    Next
End With

For a = 3 To Worksheets.Count ' vom 3. bis letzten Blatt
    z = 1 ' z ist für das Ergebnisarray
    Worksheets(a).Activate ' das muss aktiv sein, weil sonst weiter unten keine Formeln  _
eingelesen werden
                    lLetzteZeile = 0
                    lLetzteSpalte = 0
                    For aktSpalte = 1 To Worksheets(a).UsedRange.SpecialCells( _
xlCellTypeLastCell).Column
                        If Worksheets(a).Cells(Rows.Count, aktSpalte).End(xlUp).Row >  _
lLetzteZeile Then
                            lLetzteZeile = Worksheets(a).Cells(Rows.Count, aktSpalte).End(xlUp). _
Row
                        End If
                    Next
        
                    For aktZeile = 1 To Worksheets(a).UsedRange.SpecialCells(xlCellTypeLastCell) _
.Row
                        If Worksheets(a).Cells(aktZeile, Columns.Count).End(xlToLeft).Column >  _
lLetzteSpalte Then
                            lLetzteSpalte = Worksheets(a).Cells(aktZeile, Columns.Count).End( _
xlToLeft).Column
                        End If
                    Next
    ' Geht immer von A1 bis letzte Zelle
    strBereich = "$A$1:" & Worksheets(a).UsedRange.SpecialCells(xlCellTypeLastCell).Address
    ' falls keine oder nur eine beschrieben sind geben wir ihm die ersten 2 vor
    ' tun wir das nicht, läuft es auf Fehler, weil das Array nicht befüllt wird
    If lLetzteSpalte = 1 And lLetzteZeile = 1 Then strBereich = "A1:B2"
    
    ' hier kommen 2 Arrays vom genutzten Bereich
    ' die Formeln
    arBereichFormel = range(strBereich).Formula
    ' die Werte die drin stehen
    arBereichWert = range(strBereich)
    ' Ergebnis Array anpassen, Anzahl Einträge = Letzte Zeile * letzte Spalte und das Array hat  _
6 "Spalten"
    ReDim arErgebnis(1 To lLetzteZeile * lLetzteSpalte * 5, 1 To 6) ' 10 = durschnittliche  _
Verweise pro Zelle als Kennzahl für die Speicherkapatität des Arrays
    
    ' jetzt schaut er in jeden Eintrag vom Array nach
    For i = 1 To lLetzteZeile
        For j = 1 To lLetzteSpalte
            arBereichFormel(i, j) = Replace(Replace(arBereichFormel(i, j), "'", ""), "!", "")
            ' prüfen ob es eine Formel ist (spart Zeit wenn nicht)
            If InStr(arBereichFormel(i, j), "=") > 0 Then
                ' schauen ob der Suchbegriff vorkommt - dazu prüft er direkt jeden Suchbegriff
                For k = 1 To UBound(arSuche) ' ubound = Nr. vom letzten Eintrag
                    If InStr(arBereichFormel(i, j), arSuche(k)) > 0 Then
                        ' wurde der Begriff gefunden, füllen wir das Array
                        ' würde man das Ergebnis direkt eintragen würde es auch wieder ewig  _
dauern
                        m = 1
                        Do
                            ' erstes / nächstes Vorkommen von der Suche finden
                            ' m bekommt den Wert von der gefundenen Stelle + Länge vom Suchwort
                            ' m und n haben jetzt die Stelle wo der Zellverweis anfängt
                            m = InStr(m, arBereichFormel(i, j), arSuche(k)) + Len(arSuche(k))
                            ' brauchen wir weiter unten für den "Startpunkt"
                            n = m
                            Do
                                m = m + 1
                                If m > Len(arBereichFormel(i, j)) Then Exit Do
                                'solang m um 1 erhöhen bis die aktuelle Stelle kein Buchstabe  _
ist
                                'das machen wir auch um das $ Zeichen für absolute Adressen  _
einzubeziehen
                            Loop While (IsNumeric(Mid(arBereichFormel(i, j), m, 1)) = False Or  _
Mid(arBereichFormel(i, j), m, 1) = False)
                            
                            Do
                                'um paar Fehler zu umschiffen prüfen wir ob m kleiner der Länge  _
von der Formel ist
                                If m < Len(arBereichFormel(i, j)) Then m = m + 1
                                'wenn die aktuelle Position eine Zahl ist nichts tun
                                If Mid(arBereichFormel(i, j), m, 1) Like "#" Then
                                Else
                                    'ist es keine Zahl dann m-1 und do loop verlassen (wollen  _
ja nicht zu viel _
                    haben)
                                    m = m - 1
                                    Exit Do
                                End If
                                'durchlaufen solang es eine Zahl ist und wir noch nicht am Ende  _
der Formel sind
                            Loop While IsNumeric(Mid(arBereichFormel(i, j), m, 1)) = True And m  _
<> Len( _
                    arBereichFormel(i, j))
                            'Ergebnisse eintragen
                            'da wir bei A1 anfangen, können wir aus i und j die aktuelle Zelle  _
in A1 Schreibweise _
                    ermitteln
                            'On Error GoTo Fehler
                            arErgebnis(z, 1) = Replace(Cells(i, j).Address, "$", "")
                            arErgebnis(z, 2) = Worksheets(a).Name
                            arErgebnis(z, 3) = arBereichWert(i, j)
                            'auf wen verwiesen wird nehmen wir von der Suche
                            'da steht zum Beispiel 'Blatt'!
                            'wir wolle es ab dem 2. Zeichen + Zeichenlänge = Anzahl Zeichen -  _
2x ' und 1x ! also 3
                            arErgebnis(z, 5) = Mid(arSuche(k), 1, Len(arSuche(k)))
                            'Die Zelle auf die verwiesen wird ist der Startpunkt n
                            länge = m - n + 1
                            arErgebnis(z, 6) = Mid(arBereichFormel(i, j), n, m - n + 1)
'Fehler:
                            z = z + 1
                            m = m - 1
                            'solang wiederholen wie er das Suchwort nach dem aktuellen findet
                        Loop While InStr(m, arBereichFormel(i, j), arSuche(k)) > 0
                    End If

                Next
            End If
        Next
    Next
    ' er hats das Blatt durchgeackert und wenn mindestens 1 Ergebnis vorliegt, trägt er es ein
    If z <> 1 Then
        ' nächste freie Zeile suchen
        lLetzteZeile = Sheets("SheetSearchList").Cells(Rows.Count, 3).End(xlUp).Row + 1
        ' das gesamte Array ins Blatt eintragen
        Worksheets("SheetSearchList").Cells(lLetzteZeile, 3).Resize(z - 1, 6).Value =  _
arErgebnis
    End If
    ' wiederholen bis alle Blätter durch sind
Next

' arrays löschen
Erase arBereichFormel
Erase arBereichWert
Erase arErgebnis

' 1. Blatt aktivieren
Sheets("SheetMatrixOverview").Activate
Cells(1, 1).Value = "Matrix:"

For i = 3 To Worksheets.Count
    Cells(i - 1, 1).Value = Worksheets(i).Name
    Cells(1, i - 1).Value = Worksheets(i).Name
Next

' wir berechnen das direkt in VBA ohne Umweg
lLetzteZeile = Sheets("SheetSearchList").Cells(Rows.Count, 3).End(xlUp).Row
For i = 3 To Worksheets.Count
    For j = 3 To Worksheets.Count
        Cells(i - 1, j - 1).Value = Application.WorksheetFunction.CountIfs(Sheets(" _
SheetSearchList").range("D2:D" & lLetzteZeile), Worksheets(i).Name, Sheets("SheetSearchList").range("G2:G" & lLetzteZeile), Worksheets(j).Name)
    Next
Next

' alles wieder einschalten
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Exit Sub

Error:
Erase arBereichFormel
Erase arBereichWert
Erase arErgebnis
Application.Calculation = xlCalculationAutomatic ' automat.Berechnung einschalten falls ein  _
Fehler ausgegeben wird
MsgBox ("Error 404 - Page not Found")

End Sub