Code sehr langsam - Array verwenden?
04.07.2018 12:00:55
Georg
der Code weiter unten ist sehr langsam und umständlich. Leider kann ich es (noch) nicht besser.
Die Datei hat drei Blätter für die Adminsachen, dann 80 blätter die alle identisch aufgebaut sind.
Zusammenfassung was hier passiert:
1. über Input-Box wird ein Name eingegeben, z. B. Dortmund, das Blatt "Musterpraxis"wird dupliziert und zu Dortmund_2019 umbenannt, dann werden alte Daten aus dem Blatt Dortmund_2018 zu Dortmund_2019 kopiert.
2. Sobald dies abgeschlossen ist, werden zwei Übersichtsblätter mit den Daten aus Dortmund 2019 befüllt.
3. Im Anschluss wird das alte Blatt ...2018 gelöscht.
Die Eingabe 80x über Input Box ist natürlich sehr umständlich. Gibt es eine Möglichkeit, dies zu beschleunigen, in dem Sinne, dass die Übernahme der alten Daten für jedes worksheet von 3 bis 80 geht ohne Inputbox? Die Namenskonvention ist immer identisch: Städtename_2018
Es werden über eine Index Formel (hat nix direkt mit dem Code zu tun)
(=WENNFEHLER(INDEX(MatrixSchichtMuster;VERGLEICH($C$18&$E41;TabMuster&TabSchichtBez;0);VERGLEICH(S$4;TabWochentage;0))*S$5*$F41;0)
in jedem Blatt ab sheet(3) (Range g6:S41) Werte berechnet. Ich habe den Eindruck, das macht die Sache sehr langsam, gibt es eine Alternative?
Sollte man einen Array anlegen mit den Städenamen? arr(Dortmund, München, Memmingen.....)?
Ein Grund warum ich das hier poste, ist, ich muss es nochmal durchführen und möchte es
a) beschleunigen und b) noch etwas dazulernen.
Für jeden Tipp bin ich dankbar.
Option Explicit
Sub PersPlanung2019()
Dim Px As String
Px = Application.InputBox("Praxisname eingeben", "BPx")
Dim j As Integer
j = 2018
Dim PlJahr As Integer
PlJahr = 2019
Dim PxAlt As String
PxAlt = Px & "_" & j
Dim PxNeu As String
PxNeu = Px & "_" & j + 1
Dim BPxRegion As String
'Sheet Musterpraxis wird kopiert und es wird eine konkretes Blatt für eine BPx erzeugt
Sheets(1).Select
Sheets(1).Copy after:=Sheets(1) 'also z. B. Memmingen 2019 steht an Position 2
Sheets(2).Activate
ActiveSheet.Name = Px & "_" & j + 1
'Jetzt habe ich zwei: BPx Praxisname 2018 und 2019
'Jetzt sollen die Werte von 2018 übernommen werden.
With Sheets(2)
.Cells(15, 3) = Px 'Praxisname
.Cells(16, 3) = ThisWorkbook.Worksheets(PxAlt).Cells(16, 3) 'Kostenstelle
.Cells(16, 3).NumberFormat = "00000"
.Cells(17, 3) = ThisWorkbook.Worksheets(PxAlt).Cells(17, 3) 'in Betrieb
.Cells(18, 3) = ThisWorkbook.Worksheets(PxAlt).Cells(18, 3) 'Schichtmuster
.Cells(30, 3) = ThisWorkbook.Worksheets(PxAlt).Cells(30, 3) 'TZ Kraft 1
.Cells(32, 3) = ThisWorkbook.Worksheets(PxAlt).Cells(32, 3) 'TZ Kraft 2
.Cells(34, 3) = ThisWorkbook.Worksheets(PxAlt).Cells(34, 3) 'TZ Kraft 3
.Cells(43, 3) = ThisWorkbook.Worksheets(PxAlt).Cells(43, 3) 'durchschn. h gfB
.Cells(50, 3) = ThisWorkbook.Worksheets(PxAlt).Cells(50, 3) 'Ist Köpfe TZ
.Cells(51, 3) = ThisWorkbook.Worksheets(PxAlt).Cells(51, 3) 'Ist Köpfe gfB
.Cells(2, 2).Value = "Planung für: BPx " & Px & "_" & PlJahr
.Buttons(1).Name = "Praxis"
.Buttons("Praxis").Delete
End With
BPxRegion = Application.InputBox("Region eingeben", "BPxRegion")
'Das Blatt BPxÜbersicht wird befüllt:
Sheets("BPxÜbersicht").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = BPxRegion
Sheets("BPxÜbersicht").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) = Px & "_" & PlJahr
Sheets("BPxÜbersicht").Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) = ThisWorkbook.Worksheets( _
PxAlt).Cells(17, 3) 'in Betrieb
Sheets("BPxÜbersicht").Cells(Rows.Count, 5).End(xlUp).Offset(1, 0) = ThisWorkbook.Worksheets( _
PxAlt).Cells(16, 3) 'Kostenstelle
'Soll Köpfe TZ
Sheets("BPxÜbersicht").Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C37"
'Ist Köpfe TZ
Sheets("BPxÜbersicht").Cells(Rows.Count, 7).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C50"
'Soll Köpfe TZ in FTE
Sheets("BPxÜbersicht").Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C38"
'IST Köpfe TZ in FTE
Sheets("BPxÜbersicht").Cells(Rows.Count, 9).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C52"
'Soll Köpfe gfB
Sheets("BPxÜbersicht").Cells(Rows.Count, 10).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C44"
'Ist Köpfe gfB
Sheets("BPxÜbersicht").Cells(Rows.Count, 11).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C51"
'Soll gfB FTE
Sheets("BPxÜbersicht").Cells(Rows.Count, 12).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C45"
'IST gfB FTE
Sheets("BPxÜbersicht").Cells(Rows.Count, 13).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C53"
'SOLL Köpfe Gesamt
Sheets("BPxÜbersicht").Cells(Rows.Count, 14).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C47"
'IST Köpfe GESAMT
Sheets("BPxÜbersicht").Cells(Rows.Count, 15).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C54"
'Soll FTE Gesamt
Sheets("BPxÜbersicht").Cells(Rows.Count, 18).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C48"
'Ist FTE
Sheets("BPxÜbersicht").Cells(Rows.Count, 19).End(xlUp).Offset(1, 0).FormulaLocal = _
"='" & Px & "_" & PlJahr & "'!C55"
'Neues Sheet verschieben
Sheets(2).Move after:=Sheets("Controlling")
'Controlling Blatt befüllen
Sheets("Controlling").Cells(Rows.Count, 2).End(xlUp).Offset(1, 0) = BPxRegion
Sheets("Controlling").Cells(Rows.Count, 3).End(xlUp).Offset(1, 0) = PxNeu
Sheets("Controlling").Cells(Rows.Count, 4).End(xlUp).Offset(1, 0) = ThisWorkbook.Worksheets( _
PxNeu).Cells(17, 3) 'in Betrieb
Sheets("Controlling").Cells(Rows.Count, 5).End(xlUp).Offset(1, 0) = ThisWorkbook.Worksheets( _
PxNeu).Cells(16, 3) 'Kostenstelle
ThisWorkbook.Worksheets(PxNeu).Cells(16, 3).NumberFormat = "00000"
Sheets("Controlling").Cells(Rows.Count, 6).End(xlUp).Offset(1, 0) = ThisWorkbook.Worksheets( _
PxNeu).Cells(27, 3) 'Gesamtstunden
Sheets("Controlling").Cells(Rows.Count, 7).End(xlUp).Offset(1, 0) = ThisWorkbook.Worksheets( _
PxNeu).Cells(47, 3) 'Soll Köpfe
Sheets("Controlling").Cells(Rows.Count, 8).End(xlUp).Offset(1, 0) = ThisWorkbook.Worksheets( _
PxNeu).Cells(48, 3) 'Soll FTE
Sheets("Controlling").Cells(Rows.Count, 10).End(xlUp).Offset(1, 0) = ThisWorkbook.Worksheets( _
PxNeu).Cells(54, 3) 'IST Köpfe
Sheets("Controlling").Cells(Rows.Count, 11).End(xlUp).Offset(1, 0) = ThisWorkbook.Worksheets( _
PxNeu).Cells(55, 3) 'IST FTE
'2018 Blatt löschen ohne Nachzufragen
Application.DisplayAlerts = False
Worksheets(PxAlt).Delete
Application.DisplayAlerts = True
'Call BlätterSortieren
End Sub