|
<p> Hallo zusammen,</p> <p> nun kann ich wirklich sagen, dass der Code funktioniert. Ich habe ihn umfangreich getest und habe bis jetzt keine technischen Schwierigkeiten festgestellt. Ein Frage habe ich allerdings noch.</p> <p> Ich habe festgestellt, dass die Berechnung bei ein Änderung mit unter recht lange dauert (bis zu 15 Sekunden). Der Code wird im Moment auf ca. 25 Arbeitsblättern ausgeführt. Kann es sein, dass es daran liegt, dass der Code nun unter "DieseArbeitmappe" steht und daher bei jeder Änderung auf allen 25 Arbeitsblättern durchgeführt wird auch wenn die Änderung nur auf einem Arbeitsblatt erfolgt.</p> <p> Als der Code noch in jedem einzelnen Arbeitsblatt eingetragen war, ging die Berechnung deutlich schneller. Allerdings war sie fehlerhaft (siehe Beiträge zuvor). Nun stellen sich für mich zwei Fragen: 1. Woran liegt es, dass die Berechnung so lange dauert? 2. Gibt es eine Möglichkeit den Code so zu schreiben, dass er effektiver Arbeitet?</p> <p> Der Code sieht im Moment so aus:</p> <p> DieseArbeitsmappe:</p> <pre class="brush:vb;"> Private Sub Workbook_open() ' Speichern der aktuellen Werte Dim rgG As Range, i As Double 'Alle M-Zellen Set rgG = Range("M1:M400") i = 0 For Each C In rgG arrG(i) = C.Value i = i + 1 Next End Sub Private Sub Workbook_SheetActivate(ByVal Sh As Object) If Sh.Name = "Rechnung" Or Sh.Name = "Ergebnisse" Then Exit Sub Application.EnableEvents = False ' Im Tabellenblatt wurde eine Berechnung durchgeführt Dim i As Double, zeile As Double zeile = 0 ' Übereinstimmung wird geprüft (hat sich was in den M-Zellen geändert?) For i = 0 To UBound(arrG) zeile = i + 1 ' Wenn gespeicherter Wert ungleich aktueller Wert in M, dann ... If arrG(i) <> Cells(zeile, 13) Then ' ...: wenn Zelle J = alter Wert M, dann If Cells(zeile, 10) = arrG(i) Then ' Wertzuweisung J-Zelle und neuer Wert, ... arrG(i) = Cells(zeile, 13) Cells(zeile, 10) = Cells(zeile, 13) Else ' ...sonst nur M-Zelle in Array arrG(i) = Cells(zeile, 13) End If End If Next Application.EnableEvents = True End Sub Private Sub Workbook_SheetCalculate(ByVal Sh As Object) </pre> <pre class="brush:vb;"> If Sh.Name = "Rechnung" Or Sh.Name = "Ergebnisse" Then Exit SubApplication.EnableEvents = False</pre> <p> ' Im Tabellenblatt wurde eine Berechnung durchgeführt<br /> Dim i As Double, zeile As Double<br /> zeile = 0<br /> ' Übereinstimmung wird geprüft (hat sich was in den M-Zellen geändert?)<br /> For i = 0 To UBound(arrG)<br /> zeile = i + 1<br /> ' Wenn gespeicherter Wert ungleich aktueller Wert in M, dann ...<br /> If arrG(i) <> Cells(zeile, 13) Then<br /> ' ...: wenn Zelle J = alter Wert M, dann<br /> If Cells(zeile, 10) = arrG(i) Then<br /> ' Wertzuweisung J-Zelle und neuer Wert, ...<br /> arrG(i) = Cells(zeile, 13)<br /> Cells(zeile, 10) = Cells(zeile, 13)<br /> Else<br /> ' ...sonst nur M-Zelle in Array<br /> arrG(i) = Cells(zeile, 13)<br /> End If<br /> End If<br /> Next<br /> Application.EnableEvents = True<br /> End Sub<br /> <br /> Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)</p> <br /> <pre class="brush:vb;"> If Sh.Name = "Rechnung" Or Sh.Name = "Ergebnisse" Then Exit Sub' Weiterhin für manuelle Änderung in J-Zellen</pre> <p> Dim rC As Range<br /> Application.EnableEvents = False<br /> If Not Intersect(Target, Range("M1:M400")) Is Nothing Then<br /> For Each rC In Target<br /> If rC.Column = 13 Then<br /> If rC.Offset(0, -3) = "" Then rC.Offset(0, -3) = rC<br /> End If<br /> Next rC<br /> End If<br /> If Not Intersect(Target, Range("J1:J400")) Is Nothing Then<br /> For Each rC In Target<br /> If rC.Column = 10 Then<br /> If rC = "" Then rC = rC.Offset(0, 3)<br /> End If<br /> Next rC<br /> End If<br /> Application.EnableEvents = True<br /> End Sub</p> <br /> <p> Modul:</p> <pre class="brush:vb;"> ' Array-Variablen zum Speichern der Werte Public arrG(65535) As Double </pre> <p> Ich würde mich über Hilfe sehr freuen</p> <p> Besten Gruß</p> <p> Mario</p>
|