Arrayberechnung laaangsam mit Excel 2016

[Klaus-Dieter]

Hallo,

wenn schon mit einem Makro gearbeitet wird, würde ich auf das Eintragen von Formeln verzichten. Makros können auch ganz schick rechnen.

[rodlof]

Hallo

Vielen Dank für die Hilfe, die ich in diesem Forum immer wieder erfahre. Wirklich super!

Ich habe nun den Übeltäter nach umfangreichen und langwierigen Tests (einzelne Anweisungen Ein- und Ausschalten) gefunden. Es war nicht das vx-Array sondern die Einzelbehandlung der jeweils "ersten" Zeile mit Einfärben und entsperren. Komisch nur, dass das im alten Excel prima funktioniert hat.

Code:

With ActiveSheet.Cells(i, intK)             'Erste Zeile eines Artikels in Spalte intK
    .Interior.ColorIndex = 19               'hellgelb einfärben
    .Locked = False                         'und entsperren
End With

Zudem habe ich den Rat von Elex befolgt und Application.Calculation und Application.Screenupdate eingesetzt. Kannte ich beide schon, hat zwar nur wenig gebracht, aber immerhin.
Ich muss mir nun überlegen, wie ich das anders bewerkstelligen kann. Kann man die Zustände einer Zelle (zB .Locked) auch in einem Array vordefinieren?
@Klaus-Dieter: Ja ich weiss. Aber ich muss hier aus verschiedenen Gründen Formeln einsetzen.
Liebe Grüsse aus der Schweiz
R0dl0f

[schauan]

Hallöchen,

ist auch wieder etwas wenig Code. Wie viele Zellen betrifft das? Wie ermittelst Du die erste Zeile eines Artikels? Musst Du immer alle betreffenden Zellen einfärben oder reicht das Einfärben, wenn neue Artikel hinzukommen? ...
Wenn die Artikel eine feste Anzahl Zeilen haben, könntest Du das auch schon vorformatieren.

[rodlof]

Hallo
Danke allen für die Hilfe.

Ich kann schon etwas mehr Code zeigen. Im Prinzip geht es um folgendes: Ich bekomme eine Exporttabelle mit ca 50'000 bis 500'000 Zeilen. Die Header sind bekannt und etwas mehr als die die ich dann abhole. Die Reihenfolge ist nicht wichtig.

Nun habe ich 3 Schlaufen:
1. In einer internen Schlaufe habe ich unterschiedliche Bedingungen definiert. In einem Fall lese ich den eigenen Header aus und wechsle zum ExportSheet und suche dort in einer
2. externen Schlaufe einen Header, der dem internen entspricht (sofern er nicht leer, "o", "x", "y" oder "z" entspricht). Sobald ich den gefunden habe, kopiere ich alle Zellen dieser Spalte und verlasse die externe Schlaufe. Im Zielfile füge ich die Kolonne ein. 
3. In gewissen Spalten ( "x", "y" oder "z") berechne ich Hilfseinträge und in einer Spalte  (bei Case "z") bereite ich die Eingabe für den User vor. Dort muss ich alle Zeile durchgehen und dann die Zellen formatieren oder mit einer Formel füllen. Diese 3. Schlaufe hat mir nun Probleme bereitet, da sie für jede Zelle eine Berechnung oder Bedingung definieren muss. Mit 500'000 Zeilen dauert das schon eine Weile. Daher bin ich auf das Array ausgewichen, das dann als Ganzes eingefügt wird. Einzelne Zellen (die jeweils "erste" Zeile eines Artikels) sollen dem User die Möglichkeit geben, aus einer vordefinierten (zweisprachigen) Liste einen Eintrag zu machen, den ich dann auf alle Zeilen dieses Artikels übertrage und die Zelle entsperre. Die Lösung mit der Zelle entsperren habe ich noch nicht gefunden

Der Code (Auszug) sieht folgendermassen aus:

Code:

Sub InhaltTabelleAbholen1()

Dim ErsteZeile As Integer           'Die erste Zeile mit Daten (ohne Header)
Dim AnzZeilen As Long               'Anzahl Zeilen des entspr. registers mit Daten (muss long sein)
Dim LetzteZeile As Long             'Die Letzte Zeile mit Daten in einem Bereich (muss long sein)
Dim LetzteSpalte As Integer         'Die Letzte Spalte mit Daten (nur in STAO verwendet)
Dim SpalteFZ As Integer             'Die Spalte mit den Fallzahlen im Sheet STAO
Dim HeadExt(1 To 65) As String      'Aktuelle Spaltenheader im Externen Register
Dim HeadInt(1 To 65) As String      'Aktuelle Spaltenheader im Internen Register
Dim FormelLKP As String             'Formelals String für Verweise auf LKPs
Dim FormelCalc As String            'Formel als String für direkte Berechnung
Dim FormelDRP As String             'Formel als String für Wiederholung der DropDown
Dim i As Long                       'Schlaufenzähler
Dim i2 As Long                      'Schlaufenzählerhalter
Dim vx(1 To 999000, 1 To 1) As Variant      'Array für Formelvorbereitung

'*****************************
ErsteZeile = 10               'Erste Zeile im Datenregister STAO setzen

......

'*Namen der Header auslesen im internen File und zugehörige Werte Kopieren
'*************************************************************************
Application.ScreenUpdating = False

'Spalte für Spalte kopieren (für alle RegType)
For intK = 1 To 65                                      'Interne Schlaufe setzen
   'Header auslesen (muss gleich lauten wie im Exportfile, Position spielt keine Rolle)
    HeadInt(intK) = Workbooks(ZielFile).Worksheets(RegInt).Cells(1, intK).Value

   Select Case HeadInt(intK)                           'Erste unterschiedliche Behandlung je nach Header (x, y, z)
   '************************
   Case ""
       Exit For                                        'Interne Schlaufe abbrechen wenn leer (am Schluss)
           
   Case "o"
       'du nösing                                      'Nichts abholen und interne Schlaufe weiter schalten
       
   Case "x"                                            'Verweis-Formel
       '*******************                            '**************
       Windows(ZielFile).Activate                      'zurück zum Hauptfile, wenn nicht schon da
       Worksheets(RegInt).Select                       'Register wählen (hier STAO)
       Cells(2, intK).Select                           'Formelfeld anwählen
       
       FormelLKP = Cells(2, intK).Formula              'Formel zu Spalte auslesen (muss Bezug auf ErsteZeile haben)
       
       With Range(Cells(ErsteZeile, intK), Cells(AnzZeilen + ErsteZeile - 2, intK))
           .Formula = FormelLKP                        'trägt die Formeln ein
           .Formula = .Value                           'ersetzt die Formeln durch Werte
       End With
   
   Case "y"                                            'Berechnungs-Formel
       '*****************                              '*****************
       Windows(ZielFile).Activate                      'zurück zum Hauptfile
       Worksheets(RegInt).Select                       'Register wählen (hier STAO)
       Cells(2, intK).Select                           'Formelfeld anwählen
       
       FormelLKP = Cells(2, intK).Formula              'Formel zu Spalte auslesen (muss Bezug auf ErsteZeile haben)
       
       With Range(Cells(ErsteZeile, intK), Cells(AnzZeilen + ErsteZeile - 2, intK))
           .Formula = FormelLKP                        'trägt die Formeln ein
           .Formula = .Value                           'ersetzt die Formeln durch Werte
       End With
   
   Case "z"                                                'DropDown mit Auswahlliste
       '*****************                                  '*****************
       Application.Calculation = xlCalculationManual
       
       Windows(ZielFile).Activate                          'zurück zum Hauptfile
       Worksheets(RegInt).Select                           'Register wählen (hier STAO)
       ActiveSheet.Cells(2, intK).Copy                     'Formelfeld anwählen und Zelle (mit Dropdown) kopieren

       With Range(Cells(ErsteZeile, intK), Cells(AnzZeilen + ErsteZeile - 2, intK))
           .PasteSpecial _
               Paste:=xlAll, _
               Operation:=xlNone, _
               SkipBlanks:=False, _
               Transpose:=False                            'Auf alle Zeilen einsetzen
           .ClearContents                                  'Allenfalls Inhalt löschen
       End With

       For i = ErsteZeile To AnzZeilen + ErsteZeile - 2

           If ActiveSheet.Cells(i, SpalteFZ).Value = 1 Then      'Wenn FZ = 1 (in Spalte AP)
               i2 = i                                      'Erste Zeile des Falls merken
               
               '**************************************************************************
               'Dieser Color Index oder Lock False verlangsamt die ganze Routine 1000 fach!
               'With ActiveSheet.Cells(i, intK)             'Erste Zeile eines Falles in Spalte intK
               '    .Interior.ColorIndex = 19               'hellgelb einfärben
               '    .Locked = False                         'und entsperren
               'End With
               '**************************************************************************
           Else
                   FormelDRP = "=$BG$" & i2                'Formel zusammensetzen und
                   vx(1 + i - ErsteZeile, 1) = FormelDRP   'in Array eintragen


           End If

       Next i

       With ActiveSheet
           .Range(.Cells(ErsteZeile, intK), _
                  .Cells(AnzZeilen + ErsteZeile - 2, intK)) _
                   = vx                                    'Gesammeltes Array in Kolonne eintragen
       End With

       Application.Calculation = xlCalculationAutomatic        
               
   Case Else                                           'Andernfalls (wenn Header eine Variable ist)
       '*Zum Quellfile und entspr. Register wechseln
       Workbooks(QuellFile).Worksheets(RegExt).Activate
   
       For extK = 1 To 65                              'Externe Schlaufe setzen (alle Headers durchsuchen)
       '********************************************
         With Workbooks(QuellFile).Worksheets(RegExt)
           If .Cells(1, extK).Value = HeadInt(intK) Then
              .Range(Cells(2, extK), Cells(AnzZeilen, extK)).Copy
              Exit For                                 'Externe Schlaufe abbrechen wenn gefunden
           End If
         End With
       Next extK                                       'Ende der externen Schlaufe
       '*********************************************
        Windows(ZielFile).Activate                      'zurück zum Hauptfile
        Worksheets(RegInt).Select                       'Register wählen (hier STAO)
        ActiveSheet.Cells(ErsteZeile, intK).Select      'Zelle unterhalb entspr. Header anwählen
        Selection.PasteSpecial _
        Paste:=xlValues, SkipBlanks:=False, _
        Transpose:=False                               'Daten einfügen (nur Werte)
   
       Application.CutCopyMode = False                 'Copyrahmen Ameisen abschalten
       
   End Select                                          'Ende der Behandlung der Header
   '************************
Next intK                                              'Ende der internen Schlaufe

Application.ScreenUpdating = True

.....

Exit Sub
'-------------------------------------------
Fehler1:
MsgBox "Die Datei mit dem angegeben Namen " & QuellFile & "konnte nicht gefunden werden!"

End Sub

Viele Grüsse
R0dl0f

[schauan]

Hallöchen,

ich fragte ja auch, wie viele Zellen Du einfärbst Hier mal ein Code, der von 1 bis 100.000 jede zweite Zelle färbt. Dauert bei mir 7,375 Sekunden. Für 500.000 Zeilen brauchts 39.731 Sekunden.

Code:

Option Explicit
' ---------------------------------------------------------
' API Funktion GetTickCount
' Eingestellt von: Andre Schau
' Datum: 5. Juno 2012
' Kommentar: Funktion zur Ermittlung der Systemzeit
' Parameter:
' R?ckgabe:  Systemzeit
'
' weitere benoetigte Programme und Funktionen
' Aufruf:   Beispiel siehe Sub callGetTickCount()
' Hinweis:
' ---------------------------------------------------------
'Deklaration der API-Funktion
Private Declare Function GetTickCount Lib "kernel32.dll" () As Long

Sub callGetTickCount()
'Variablendeklaration
'Long
Dim loStartTime As Long, iCnt As Long
'Startzeit uebernehmen
loStartTime = GetTickCount
'3s warten
'Application.Wait (Now + TimeValue("0:00:03"))
For iCnt = 1 To 100000 Step 2
With ActiveSheet.Cells(iCnt, 1)             'Erste Zeile eines Falles in Spalte intK
    .Interior.ColorIndex = 19               'hellgelb einf?rben
    .Locked = False                         'und entsperren
End With
Next
'Meldung Laufzeit in Sekunden aus Differenz von Systemzeit
'und Startzeit / 1000
MsgBox "Laufzeit " & _
  (GetTickCount - loStartTime) / 1000 & " Sekunden.", _
    vbInformation, "Application.Wait Soll: 3 Sekunden"
End Sub

[rodlof]

Hallo Schauan

Danke für den Timer. Ich habe den bei mir installiert und laufen lassen. Und da haben wir das Problem: Mit 100'000 hatte ich gar nicht die Geduld und musste abbrechen und Excel neu starten. Ich habe es dann mit iCnt = 10 To 1000 Step 2 versucht und da erhalte ich 29.968 Sekunden. Mit 100'000 oder 500'000 ist das nicht zumutbar.

Ich nehme an, dass die Installation der neuen Excel Version Schuld ist. Da haben die bei uns in der Zentrale etwas verbockt. Ich habe leider überhaupt keine Rechte und kann an der Installation nichts schrauben. Und wenn ich denen etwas von VBA sage, kriegen die lange Gesichter....
 

Ich versuche es jetzt mal so: Ich sammle alle Adressen der Zellen, die entsperrt und gefärbt werden müssen in einem String mit Komma und übergebe den als Range, den ich dann mit 1 Befehl formatiere. Ev muss ich für die Ranges mehrere Abschnitte machen.

Gruss
R0dl0f

[schauan]

Hallöchen,

das mit dem String dauert ggf. noch länger und kann dann mit einem Range(...) nicht mehr verarbeitet werden, wenn's zu lang wird

[rodlof]

Hallo Schauan

Ich habe nun die neue Lösung. Mit deinem Timer komme ich so bei 100'000 auf 0.391 Sekunden. Das ist doch schon viel besser. Ich versuche das nun einzubauen.

Der Code ist folgendermassen:

Code:

Sub callGetTickCount()
Dim loStartTime As Long, iCnt As Long
'Startzeit uebernehmen

Dim Bereich1 As Range
Dim BereichAlle As Range

loStartTime = GetTickCount

Set BereichAlle = Cells(10, 70)

For iCnt = 11 To 100000
   If Cells(iCnt, 39).Value = 1 Then
       Set Bereich1 = Cells(iCnt, 70)
       Set BereichAlle = Union(BereichAlle, Bereich1)
   Else:           'du nösing
   End If
Next

BereichAlle.Select
Selection.Locked = False

'Meldung Laufzeit in Sekunden aus Differenz von Systemzeit
'und Startzeit / 1000
msgbox "Laufzeit " & _
 (GetTickCount - loStartTime) / 1000 & " Sekunden.", _
   vbInformation, "Application.Wait Soll: 3 Sekunden"
End Sub

Vielen Dank für deine Hilfe
Gruss
R0dl0f

[snb]

Code:

Sub M_snb()
   application.screenupdating = false

   with UsedRange
       .AutoFilter 19, 1
       .Locked = False
       .AutoFilter
   end with
End Sub

[rodlof]

Hallo zusammen

So, nun habe ich mir den Sonntag um die Ohren geschlagen. Aber ich habe es endlich rausgefunden. Danke snb für den Tipp. Die erste neue Methode dauerte zwar auf dem Testsheet nur kurz auch mit 500'000 Zeilen. Aber als ich es dann in die grosse Tabelle eingebaut habe, ging Excel wieder in die Knie.

Nun habe ich folgende Lösung, die für den ganzen Vorgang (also noch viele andere Prozeduren) nur 40 sec braucht (bei aktuell 70'000 Einträgen). Das ist eine erträgliche Zeit.

Der Code sieht nun so aus:

Code:

Application.ScreenUpdating = False

.....

For s = 1 To 2
ActiveSheet.Range _
    ("B" & ErsteZeile - 1).AutoFilter _
    Field:=SpalteFZ - 1, _
    Criteria1:=1 

ActiveSheet.Range _
    (Cells(ErsteZeile, SpalteSelect(s)), _
    Cells(LetzteZeile, SpalteSelect(s))) _
    .Locked = False
Next s

ActiveSheet.ShowAllData

....

Application.ScreenUpdating = True

Vielen Dank allen, die mitgedacht haben.
Morgen geht es in die Ferien ab nach Fuerteventura. Daher musste das jetzt noch sein.
Yeepee
Liebe Grüsse
R0dl0f