Spalte kopieren dauert zu lange
10.06.2016 08:50:39
cH_rI_sI
ich habe einen Projektplan so umgebaut, damit bei Eingabe eines Enddatums in der Zelle "C10" die Anzahl der erforderlichen Spalten automatisch erzeugt werden.
Funktioniert soweit auch, bis auf die Performance - wie kann man die Wartezeit verkürzen? Eventuell kann ja mein Code noch optimiert werden...
Dann habe ich noch ein Problem - wenn ich die letzte Spalte des Kalenders formatiere - d.h. eine weiße, leere Spalte daraus mache, dann funktioniert meine "Tageslinie" nicht mehr (diese Linie wird beim Öffnen autom. gesetzt).
Anbei der Code für das Setzen der Linie:
Option Explicit
Private Sub Workbook_Open()
Dim shp As Shape
Dim dattab As Range
Dim datum As Date
Dim i As Long
Set shp = ActiveSheet.Shapes("Gerade Verbindung 3")
Range("A1") = 0
Set dattab = ActiveSheet.Range("Q12:AQD12")
' actual date
datum = Now()
' user defined date
If Range("C9") > 0 Then
datum = Range("C9")
End If
' find the date in the date table
For i = 1 To 1100
If datum = dattab(1, 1100) Then
Range("A1") = 1100
End If
' for dates before first date mark column AD
If datum Und auch noch der auskommentierte Code (siehe ganz unten) welcher die Funktion der "Tageslinie" zerstört:
Sub Spalten_Kopieren()
Dim AnzahlKopieren As Long
Dim lSpalte As Long
Dim PlusSpalte As Long
Dim Ende As Long
Dim n As Integer
Dim leere_Spalte As Long
Application.ScreenUpdating = False
AnzahlKopieren = Range("C11") - 2
Range(Cells(1, 1), Cells(1, 16384)).EntireColumn.Hidden = False
'Range(Cells(1, 31), Cells(1, 16384)).Select
' Selection.FormatConditions.Delete
' Selection.Clear
lSpalte = Range(Cells(1, 24), Cells(1, 30)).Column
PlusSpalte = lSpalte
Ende = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Range(Cells(1, 30), Cells(Ende, lSpalte)).Copy
For n = 1 To AnzahlKopieren
Cells(1, lSpalte + 7).Select
ActiveSheet.Paste
lSpalte = lSpalte + 7
Next n
Range(Cells(1, lSpalte + 8), Cells(1, 16384)).EntireColumn.Hidden = True
'leere_Spalte = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Column
'Columns(leere_Spalte).Select
' Selection.Clear
' Selection.Activate
' With Selection.Interior
' .Pattern = xlSolid
' .PatternColorIndex = xlAutomatic
' .ThemeColor = xlThemeColorDark1
' .TintAndShade = 0
' .PatternTintAndShade = 0
' End With
Cells(10, 3).Select
Application.ScreenUpdating = True
End Sub
https://www.herber.de/bbs/user/106136.xlsm
Wäre echt super, wenn mir jemand helfen könntet - Danke!
Lg,
Chrisi