Makro mit verknüpten Bildern sehr langsam
07.05.2007 15:36:00
Jürgen
ich habe eine Arbeitsmappe mit 3 Blättern. Auf Blatt 1 steht in Spalte A nur der Pfad zu der entsprechenden Textdatei die ioch prüfe. Auf Blatt 2 befindet sich die Auswertung der Textdateien. Auf dem 3. Blatt wird dann das Ergebnis der Auswertung dargestellt über ein Balkendiagramm das mit verknüpften Bildern erstellt wird.
Wenn cih dieses 3. Blatt aus meiner Mappe entferne, benötigt die Auswertung etwa 3-4 Sekunden. Lasse ich dieses Blatt in der Mappe dauert das ganze 2-3 Minuten. Habe schon probiert Application.Calculation abzuschalten, brachte aber keine Besserung. Das Makro greift auch in keiner Weise während der Auswertung auf Blatt 3 zu. Hat jemand eine Idee warum es mit dem 3. Blatt so langsam ist?
Hier mal der Code der das Auswerten übernimmt:
Sub Auswerten()
Sheets(3).Application.Calculation = xlCalculationManual
Dim no_FIN As Integer
Dim Context_Fin As Integer
Dim Com_Fin As Integer
Dim Bewaehrung_Fin As Integer
Dim Fin_Array1, Fin_Array2
Dim Fin_unterschied As Integer, Fin_Gleich As Integer
Dim x As Integer, y As Integer
Dim IO As Boolean
IO = True
Sheets(2).Activate
Spalte = ActiveSheet.UsedRange.Columns.Count
For j = 1 To Spalte Step 7
For i = 1 To ActiveSheet.UsedRange.Rows.Count
If Cells(i, j + 1) = "nicht vorh.|" And Cells(i, j + 2) = "nicht vorh.|" Then 'And _
_
_
Cells(i, j + 3) = "nicht vorh.|" Then
no_FIN = no_FIN + 1
Cells(i, 6) = 0
ElseIf Len(Cells(i, j + 1)) > 17 And Cells(i, j + 2) = "nicht vorh.|" Then
If Cells(i, j + 1) "-----------------|" Then
Context_Fin = Context_Fin + 1
Cells(i, 6) = 1
Else
no_FIN = no_FIN + 1
Cells(i, 6) = 0
End If
ElseIf Len(Cells(i, j + 2)) > 17 And Cells(i, j + 1) = "nicht vorh.|" Then
If Cells(i, j + 2) "-----------------|" Then
Com_Fin = Com_Fin + 1
Cells(i, 6) = 1
Else
no_FIN = no_FIN + 1
Cells(i, 6) = 0
End If
ElseIf Len(Cells(i, j + 1)) > 17 And Len(Cells(i, j + 2)) > 17 Then
Fin_Array1 = Split(Cells(i, j + 1), "|")
Fin_Array2 = Split(Cells(i, j + 2), "|")
For x = 0 To UBound(Fin_Array1) - 1
For y = 0 To UBound(Fin_Array2) - 1
If LCase(Trim(Fin_Array1(x))) LCase(Trim(Fin_Array2(y))) Then
IO = False
Fin_unterschied = Fin_unterschied + 1
Cells(i, 6) = (UBound(Fin_Array1)) + (UBound(Fin_Array2))
Cells(i, 7) = "X"
Exit For
End If
Next y
If IO = False Then Exit For
Next x
If IO = True Then
Fin_Gleich = Fin_Gleich + 1
Cells(i, 6) = (UBound(Fin_Array1)) + (UBound(Fin_Array2))
End If
End If
If IsEmpty(Cells(i, 6)) Then
no_FIN = no_FIN + 1
Cells(i, 6) = 0
End If
If Not (IsEmpty(Fin_Array1)) Then
Erase Fin_Array1
End If
If Not (IsEmpty(Fin_Array2)) Then
Erase Fin_Array2
End If
IO = True
Next i
Next j
With Sheets(3)
.Cells(1, 1) = "Keine FIN"
.Cells(2, 1) = no_FIN
.Cells(1, 2) = "Nur CONTEXT"
.Cells(2, 2) = Context_Fin
.Cells(1, 3) = "Nur VinFromCOM"
.Cells(2, 3) = Com_Fin
.Cells(1, 4) = "Mehrere FIN's"
.Cells(2, 4) = Fin_Gleich
.Cells(1, 5) = "Unterschiedl. FIN's"
.Cells(2, 5) = Fin_unterschied
End With
Sheets(3).Application.Calculation = xlCalculationAutomatic
End
End Sub
Gruß
Jürgen