Code optimieren
11.12.2012 10:52:48
Fritz_W
zwar funktioniert der nachfolgende Code wie gewünscht, dennoch dauert die Ausübung
des Makros 'Vervollstaendigen' in einzelnen Fällen etwas lange(bis zu 4 Sekunden).
Vielleicht können mir die VBA-Experten Änderungsvorschläge unterbreiten, damit die Laufzeit des Makros ggf. verkürzt werden kann.
Im Voraus besten Dank für Eure Unterstützung.
mfg
Fritz
Sub Vervollstaendigen()
Application.ScreenUpdating = False
If Tabelle1.Range("A1").Value = 1 Then
Call Ergaenzen1
Tabelle2.Range("D4:L12").Value = Tabelle1.Range("D6:L14").Value
End If
Call Ergaenzen2
Application.ScreenUpdating = True
End Sub
Sub Ergaenzen1()
Dim ArrayData, tmpArr, n&, nn&
Tabelle1.Range("CY6:DG14").Value = Tabelle1.Range("D6:L14").Value
Tabelle1.Range("O11").Value = Tabelle1.Range("O10").Value
Tabelle1.Range("O10").Value = 4
With Tabelle1.Range("D18:L26")
Do While Tabelle1.Range("D17") > 0
ArrayData = .Value
tmpArr = .Offset(-12, 0).FormulaR1C1
For n = 1 To UBound(ArrayData)
For nn = 1 To UBound(ArrayData, 2)
If ArrayData(n, nn) "" Then
If IsNumeric(ArrayData(n, nn)) Then tmpArr(n, nn) = ArrayData(n, nn)
End If
Next nn
Next n
.Offset(-12, 0).FormulaR1C1 = tmpArr
Loop
End With
Tabelle1.Range("O10").Value = Tabelle1.Range("O11").Value
End Sub
Sub Ergaenzen2()
If Tabelle1.Range("A1").Value = 1 And Tabelle1.Range("A2").Value = 0 Then
Tabelle2.Range("D4:L12").Value = Tabelle1.Range("D6:L14").Value
Call Variante_1
Call Variante_2
Call Variante_3
Call Variante_4
Call Variante_5
Call Variante_6
Call Variante_7
Call Variante_8
End If
End Sub
Sub Variante_1()
If Tabelle1.Range("A2").Value = 0 Then
Tabelle1.Range("P12").Value = 1
Call Einfuegen_2
Tabelle1.Range("P12").Value = 2
Call Einfuegen_2
Tabelle1.Range("P12").Value = 3
Call Einfuegen_2
End If
If Tabelle1.Range("A2").Value = 0 Then
Call Ergaenzen1
End If
If Tabelle1.Range("A3").Value = 1 Then
Tabelle1.Range("D6:L14").Value = Tabelle2.Range("D4:L12").Value
End If
End Sub
Sub Variante_2()
If Tabelle1.Range("A2").Value = 0 Then
Tabelle1.Range("P12").Value = 1
Call Einfuegen_1
Tabelle1.Range("P12").Value = 2
Call Einfuegen_1
Tabelle1.Range("P12").Value = 3
Call Einfuegen_1
End If
If Tabelle1.Range("A2").Value = 0 Then
Call Ergaenzen1
End If
If Tabelle1.Range("A3").Value = 1 Then
Tabelle1.Range("D6:L14").Value = Tabelle2.Range("D4:L12").Value
End If
End Sub
Sub Variante_3()
If Tabelle1.Range("A2").Value = 0 Then
Tabelle1.Range("P12").Value = 1
Call Einfuegen_2
Tabelle1.Range("P12").Value = 2
Call Einfuegen_1
Tabelle1.Range("P12").Value = 3
Call Einfuegen_1
End If
If Tabelle1.Range("A2").Value = 0 Then
Call Ergaenzen1
End If
If Tabelle1.Range("A3").Value = 1 Then
Tabelle1.Range("D6:L14").Value = Tabelle2.Range("D4:L12").Value
End If
End Sub
Sub Variante_4()
If Tabelle1.Range("A2").Value = 0 Then
Tabelle1.Range("P12").Value = 1
Call Einfuegen_2
Tabelle1.Range("P12").Value = 2
Call Einfuegen_2
Tabelle1.Range("P12").Value = 3
Call Einfuegen_1
End If
If Tabelle1.Range("A2").Value = 0 Then
Call Ergaenzen1
End If
If Tabelle1.Range("A3").Value = 1 Then
Tabelle1.Range("D6:L14").Value = Tabelle2.Range("D4:L12").Value
End If
End Sub
Sub Variante_5()
If Tabelle1.Range("A2").Value = 0 Then
Tabelle1.Range("P12").Value = 1
Call Einfuegen_1
Tabelle1.Range("P12").Value = 2
Call Einfuegen_2
Tabelle1.Range("P12").Value = 3
Call Einfuegen_1
End If
If Tabelle1.Range("A2").Value = 0 Then
Call Ergaenzen1
End If
If Tabelle1.Range("A3").Value = 1 Then
Tabelle1.Range("D6:L14").Value = Tabelle2.Range("D4:L12").Value
End If
End Sub
Sub Variante_6()
If Tabelle1.Range("A2").Value = 0 Then
Tabelle1.Range("P12").Value = 1
Call Einfuegen_1
Tabelle1.Range("P12").Value = 2
Call Einfuegen_2
Tabelle1.Range("P12").Value = 3
Call Einfuegen_2
End If
If Tabelle1.Range("A2").Value = 0 Then
Call Ergaenzen1
End If
If Tabelle1.Range("A3").Value = 1 Then
Tabelle1.Range("D6:L14").Value = Tabelle2.Range("D4:L12").Value
End If
End Sub
Sub Variante_7()
If Tabelle1.Range("A2").Value = 0 Then
Tabelle1.Range("P12").Value = 1
Call Einfuegen_1
Tabelle1.Range("P12").Value = 2
Call Einfuegen_1
Tabelle1.Range("P12").Value = 3
Call Einfuegen_2
End If
If Tabelle1.Range("A2").Value = 0 Then
Call Ergaenzen1
End If
If Tabelle1.Range("A3").Value = 1 Then
Tabelle1.Range("D6:L14").Value = Tabelle2.Range("D4:L12").Value
End If
End Sub
Sub Variante_8()
If Tabelle1.Range("A2").Value = 0 Then
Tabelle1.Range("P12").Value = 1
Call Einfuegen_2
Tabelle1.Range("P12").Value = 2
Call Einfuegen_1
Tabelle1.Range("P12").Value = 3
Call Einfuegen_2
End If
If Tabelle1.Range("A2").Value = 0 Then
Call Ergaenzen1
End If
If Tabelle1.Range("A3").Value = 1 Then
Tabelle1.Range("D6:L14").Value = Tabelle2.Range("D4:L12").Value
End If
End Sub
Sub Einfuegen()
Tabelle1.Range("CY6:DG14").Value = Tabelle1.Range("D6:L14").Value
Dim ArrayData, tmpArr, n&, nn&
With Tabelle1.Range("D18:L26")
ArrayData = .Value
tmpArr = .Offset(-12, 0).FormulaR1C1
For n = 1 To UBound(ArrayData)
For nn = 1 To UBound(ArrayData, 2)
If ArrayData(n, nn) "" Then
If IsNumeric(ArrayData(n, nn)) Then tmpArr(n, nn) = ArrayData(n, nn)
End If
Next nn
Next n
.Offset(-12, 0).FormulaR1C1 = tmpArr
End With
Tabelle1.Range("CY18:DG26").Value = Tabelle1.Range("D6:L14").Value
End Sub
Sub Einfuegen_1()
Dim ArrayData, tmpArr, n&, nn&
With Tabelle1.Range("D28:L36")
ArrayData = .Value
tmpArr = .Offset(-22, 0).FormulaR1C1
For n = 1 To UBound(ArrayData)
For nn = 1 To UBound(ArrayData, 2)
If ArrayData(n, nn) "" Then
If IsNumeric(ArrayData(n, nn)) Then tmpArr(n, nn) = ArrayData(n, nn)
End If
Next nn
Next n
.Offset(-22, 0).FormulaR1C1 = tmpArr
End With
End Sub
Sub Einfuegen_2()
Dim ArrayData, tmpArr, n&, nn&
With Tabelle1.Range("D38:L46")
ArrayData = .Value
tmpArr = .Offset(-32, 0).FormulaR1C1
For n = 1 To UBound(ArrayData)
For nn = 1 To UBound(ArrayData, 2)
If ArrayData(n, nn) "" Then
If IsNumeric(ArrayData(n, nn)) Then tmpArr(n, nn) = ArrayData(n, nn)
End If
Next nn
Next n
.Offset(-32, 0).FormulaR1C1 = tmpArr
End With
End Sub