Programm Optimierung
06.06.2013 16:20:44
Laura
ich habe folgendes Problem. Ich bin momentan dabei mein erstes VBA Programm zu schreiben. Es funktioniert nun auch einwandfrei. Allerdings arbeitet es noch relativ langsam. Das wird vor allem zum Tragen kommen, wenn ich den Berechnungsbereich in meinem Excel Sheet (wie geplant) vergrößern möchte. Kann mir da vielleicht jemand helfen und mir sagen wie ich den Code gegebenenfalls ändern kann, damit das alles etwas schneller geht. Das wäre total nett. :-)
Vielen Dank, Laura
Zum Ausprobieren des Programms:
Damit das Programm läuft, muss man 10 Tabellenbätter erzeugen mit den Namen t1, t2, t3, t4, ... t10
und ein Tabellenblatt "Parameter", bei dem in Zelle D7 eine 10 steht und in D17 z.B. eine 2.
Ansonsten habe ich versucht den Code möglichst ausführlich zu kommentieren, damit das nicht zu _ viel Zeit frisst, den Gedanken nachzuvollziehen.
Private Sub CommandButton2_Click()
Dim w As Integer
Dim y As Variant
y = Sheets("Parameter").Range("D7").Value
For w = y To 2 Step -1
Worksheets("t" & w).Select 'Aktiviert das Tabellenblatt _
_
_
"tw"
ActiveSheet.Cells.Select 'Aktiviert alle Zellen
Selection.ClearContents 'Löscht alle Einträge aus _
den Zellen
Sheets("t" & w - 1).Select 'Aktiviert das _
Tabellenblatt "tw-1"
ActiveSheet.Cells.Select 'Aktiviert alle Zellen
Selection.Copy 'Kopiert alle Einträge
Sheets("t" & w).Select 'Aktiviert das _
Tabellenblatt "tw"
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
'Fügt Werte und _
_
_
Zahlenformate ein
ActiveSheet.Range("A1").Select 'Aktiviert Zelle A1 des _
aktuellen Blatts "tw",
'damit die _
Zellauswahl aufgehoben wird
Next w
Worksheets("t1").Select 'Aktiviert das Tabellenblatt "t1"
ActiveSheet.Cells.Select 'Aktiviert alle Zellen
Selection.ClearContents 'Löscht alle Einträge aus den Zellen
For Each Zelle In Worksheets("t1").Range("B2:AY46").Cells
' Schleife, die in "t1" in jede Zelle eines ausgewählten Bereiches (Range("...:...")) eine _
_
_
zufällige Zahl zwischen
' a und b schreibt
a = 10000
b = 1
Randomize 'Initialisiert Zufallsgenerator, verwendet Rü _
ckgabewert der Timerfunktion
'als neuen Startwert
Zelle.Value = Rnd * (b - a) + a 'Zufallszahl zwischen a und b
Next Zelle
Dim Bereich As Range
Set Bereich = Worksheets("t1").Range("B2:AY46") 'Definiert den ausgewählten _
_
_
Bereich als "Bereich"
Bereich.Find(Application.Max(Bereich)).Select 'Findet und aktiviert _
Zelle mit max Eintrag im "Bereich"
c = Application.Max(Worksheets("t1").[B2:AY46]) 'Setzt Wert dieser Zelle _
gleich c
For Each Zelle In Worksheets("t1").Range("B2:AY46").Cells
'Schleife setzt den Wert der Zelle mit dem max Eintrag c auf 1, alle anderen Zellwerte _
werden auf 0 gesetzt
If Zelle.Value = c Then
Zelle.Value = 1
Else
Zelle.Value = 0
End If
Next Zelle
Dim zeile As Integer
Dim spalte As Integer
zeile = ActiveCell.Row 'Definiert Zeile = Zeilenzahl der _
aktiven Zelle mit der 1
spalte = ActiveCell.Column 'Definiert Spalte = Spaltenzahl der aktiven _
_
_
Zelle mit der 1
Dim p As Variant
p = Sheets("Parameter").Range("D17").Value 'Liest den eingetragenen Wert für p aus dem _
_
_
"Parameter" Blatt (D17)
For Each Zelle In Worksheets("t1").Range("B2:AY46").Cells
'Schleife kontrolliert alle Zellen im Bereich auf den 1-Eintrag. Wenn dieser gefunden wird, _
_
_
dann werden die umliegenden
'Zellen (quadratisch mit Kantenlnge 2p+1) um den 1-Eintrag auch 1 gesetzt
'On Error Resume Next: hat den Zweck, dass wenn das Primrion nah Rand des Tabellenblattes _
_
_
einfllt, so dass 2p+1 nicht
'mehr im Bereich des Tabellenblattes liegt, kein Fehler auftritt und die Schleife weiter _
arbeitet.
For i_counter = 1 To p
If Zelle.Value = 1 Then Worksheets("t1").Cells(zeile + i_counter, spalte) = 1
On Error Resume Next
If Zelle.Value = 1 Then Worksheets("t1").Cells(zeile - i_counter, spalte) = 1
On Error Resume Next
If Zelle.Value = 1 Then Worksheets("t1").Cells(zeile, spalte + i_counter) = 1
On Error Resume Next
If Zelle.Value = 1 Then Worksheets("t1").Cells(zeile, spalte - i_counter) = 1
On Error Resume Next
For j_counter = 1 To p
If Zelle.Value = 1 Then Worksheets("t1").Cells(zeile + i_counter, spalte + _
j_counter) = 1
On Error Resume Next
If Zelle.Value = 1 Then Worksheets("t1").Cells(zeile + i_counter, spalte - _
j_counter) = 1
On Error Resume Next
If Zelle.Value = 1 Then Worksheets("t1").Cells(zeile - i_counter, spalte + _
j_counter) = 1
On Error Resume Next
If Zelle.Value = 1 Then Worksheets("t1").Cells(zeile - i_counter, spalte - _
j_counter) = 1
On Error Resume Next
Next j_counter
Next i_counter
Next Zelle
For w = 1 To y
'Für alle Blätter werden alle Zellen mit einer 1 grün eingefärbt
Worksheets("t" & w).Range("B2:AY46").Cells.FormatConditions.Add Type:=xlCellValue, _
Operator:=xlEqual, _
Formula1:="1"
Worksheets("t" & w).Range("B2:AY46").Cells.FormatConditions(1).Interior.ColorIndex = 43
Next w
End Sub