Hallo,
ich lese mit einem Makro eine recht große Matrix aus und suche nach gemeinsamkeiten.
Nehmen wir an, er hat 1000 Felder gefunden, die er in ein Array schreibt. Zu jedem Feld gehören 5 Weitere Felder.
Anschließend werden diese 6000 Felder in ein anderes Tabellenblatt untereinander geschrieben.
Sheets("Grundeinstellungen").Cells(30, 12) = "Daten werden geschrieben"
With Sheets("Affinitätenliste 3")
For x = 1 To z
For y = 1 To 6
.Cells(x + 5, y) = output(x, y) ' alle Werte rausschreiben
Next y
.Cells(x + 5, 7) = output(x, 1) ' ersten Wert zusätzlich rausschreiben


Next x
Dies dauert mit dem obigem Code mehrere Minuten. Woran liegt das?
Muss leider um 18:30 weg. Antworten um den Zeitraum herum, kann ich dann erst um Mitternacht beantworten.
Vielen Dank für Eure Hilfe,
Gruß Pascal
Hier noch mal der gesamte Code
Variablen des Arrays dimensionieren
Dim Ar(256, 256)
Dim i(10), j(10)
Dim output(64000, 6)
Dim x, y, e, f, z
' N
e = Sheets("Grundeinstellungen").Cells(28, 5) 'Eingabefeld Schwellenwert min
f = Sheets("Grundeinstellungen").Cells(30, 5) 'Eingabefeld Schwelenwert max
z = 1 'Beginn Spalte Outputtabelle

' Aunzahl gefundene Abhängigkeiten auf Null setzen
Sheets("Grundeinstellungen").Cells(28, 20) = 0
' Array auslesen
For y = 8 To 245
For x = 3 To 245
If (Sheets("Affinität").Rows(y).Hidden = False And Sheets("Affinität").Columns(x).Hidden = False) Or Sheets("Affinität").Cells(y, 2) = 0 _
Then Ar(y, x) = Sheets("Affinität").Cells(y, x) Else Ar(y, x) = -1
Next x
Next y
' Algorhythmus
For y = 8 To 245
For x = 3 + (y - 7) To 246
If Ar(y, x) > e And Ar(y, x) < f Then
For i(1) = x + 1 To 245
If Ar(y, i(1)) > e And Ar(y, i(1)) < f And Ar(5 + i(1), x) > e And _
Ar(5 + i(1), x) < f Then
z = z + 1
output(z, 1) = Sheets("Affinität").Cells(7, x)
output(z, 2) = Ar(y, x)
output(z, 3) = Sheets("Affinität").Cells(7, y - 5)
output(z, 4) = Ar(y, i(1))
output(z, 5) = Sheets("Affinität").Cells(7, i(1))
output(z, 6) = Ar(5 + i(1), x)
Sheets("Grundeinstellungen").Cells(28, 20) = z - 1
End If
Next i(1)
End If
Next x
Next y

' Output rausschreiben
Sheets("Affinitätenliste 3").Range("A7:g64000").ClearContents
Sheets("Grundeinstellungen").Cells(30, 12) = "Daten werden geschrieben"
With Sheets("Affinitätenliste 3")
For x = 1 To z
For y = 1 To 6
.Cells(x + 5, y) = output(x, y) ' alle Werte rausschreiben
Next y
.Cells(x + 5, 7) = output(x, 1) ' ersten Wert zusätzlich rausschreiben


Next x
End With
Sheets("Grundeinstellungen").Cells(30, 12) = "Fertig"