Hi,
erstmal vielen Dank. Auch wenn es mir ein bischen peinlich ist, aber irgendwie krieg ich das nicht hin. Sitze jetzt seit ca. 2 Wochen an Dieser Liste und soweit geht ja auch alles, aber scheinbar bin ich grad zu beschränkt...
Dein Code läuft in eine Endlosschleife. Ich schick dir mal den ganzen Code, evtl. hast du ja Zeit dir das mal anzuschauen und auch nen Tip wie ich mein Problem löse...
Danke vorab.
Option Explicit
Type TaskInformation
TaskResource As String
TaskIdent As String
TaskTime1 As Long
TaskTime2 As Long
TaskComplete As Single
TaskComment As String
End Type
Public Const FirstTaskRow As Integer = 4
Sub UpdateTaskChartSheet()
Dim ActiveTask As TaskInformation
Dim R As Long, LRN As Long, shp As Shape, eCount As Integer
Dim coll As Collection, strItem As String, i As Long
ThisWorkbook.Activate
If Not WorksheetsExist Then Exit Sub
Application.ScreenUpdating = False
Application.StatusBar = "alte Gantt löschen..."
DeleteAllShapes wsTaskChart
With wsTaskChart
.Rows("3:" & .Rows.Count).ClearContents
End With
Application.StatusBar = "chart updaten..."
wsTaskList.Activate
LRN = LastRowNumber(1, True)
Set coll = New Collection
For R = FirstTaskRow To LRN
strItem = vbNullString
On Error Resume Next
strItem = Trim(Range("A" & R).Value)
coll.Add strItem, strItem
On Error GoTo 0
Next R
eCount = 0
For i = 1 To coll.Count
Application.StatusBar = "Updating chart " & Format(i / coll.Count, "0%") & "..."
wsTaskChart.Range("A" & 2 + i).Formula = coll(i)
For R = FirstTaskRow To LRN
strItem = vbNullString
On Error Resume Next
strItem = Trim(wsTaskList.Range("A" & R).Value)
On Error GoTo 0
If strItem = coll(i) Then
ActiveTask = ReadTaskInfo(wsTaskList, R)
eCount = eCount + CreateTaskShape(ActiveTask)
End If
Next R
Next i
Set coll = Nothing
wsTaskChart.Activate
With ActiveWindow
.ScrollRow = 1
.ScrollColumn = 1
End With
Range("B3").Select
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub
Private Function WorksheetsExist() As Boolean
Dim ws As Worksheet
WorksheetsExist = False
On Error GoTo NoTaskList
Set ws = wsTaskChart
On Error GoTo NoTaskChart
Set ws = wsTaskList
On Error GoTo 0
Set ws = Nothing
WorksheetsExist = True
Exit Function
NoTaskList:
Set ws = Nothing
MsgBox "Blatt nicht gefunden" & Chr(13) & _
"Macros kontrollieren", vbCritical, ThisWorkbook.Name
Exit Function
NoTaskChart:
Set ws = Nothing
MsgBox "Blatt nicht gefunden" & Chr(13) & _
"acros kontrollieren", vbCritical, ThisWorkbook.Name
Exit Function
End Function
Private Function CreateTaskShape(TaskInfo As TaskInformation) As Integer
Dim TaskBarFGcolor As Long, TaskBarBGcolor As Long
Dim TaskBarDoneFGcolor As Long, TaskBarDoneBGcolor As Long
Dim TaskBarCommentFGcolor As Long, TaskBarCommentBGcolor As Long
Dim TaskBarCommentSize As Single, MinTaskDuration As Integer
Dim rHeight As Single, cWidth As Single, ppDay As Single, minPos As Single, maxPos As Single
Dim TaskLeftPos As Long, TaskTopPos As Long, TaskWidth As Long, TaskHeight As Long
Dim StartDate As Long, EndDate As Long, CompleteTime As Double, shpNames(4) As String, shpCount _
As Integer
Dim i As Integer, LRN As Long, LCN As Integer, OK As Boolean, PlotRow As Integer, PlotColumn As _
Integer, PlotAlt As Integer
Dim tshpName As String, pcDate As Long
Dim ChartOption As Integer
With wsOptions
TaskBarFGcolor = .Range("BarColorFG").Interior.Color
TaskBarBGcolor = .Range("BarColorBG").Interior.Color
TaskBarDoneFGcolor = .Range("DoneColorFG").Interior.Color
TaskBarDoneBGcolor = .Range("DoneColorBG").Interior.Color
TaskBarCommentFGcolor = .Range("CommentColorFG").Interior.Color
TaskBarCommentBGcolor = .Range("CommentColorBG").Interior.Color
TaskBarCommentSize = .Range("CommentSize").Value
MinTaskDuration = .Range("TaskDuration").Value
End With
With TaskInfo
If .TaskTime1 > -1 Or .TaskTime2 > -1 Then
If .TaskTime1 = -1 Then .TaskTime1 = .TaskTime2 - MinTaskDuration
If .TaskTime2 = -1 Then .TaskTime2 = .TaskTime1 + MinTaskDuration
Else
Exit Function
End If
End With
wsTaskChart.Activate
PlotRow = Range("A" & Rows.Count).End(xlUp).Row
If PlotRow = TaskInfo.TaskTime1 Then OK = True
Loop
If OK Then PlotColumn = PlotColumn + Range("DateRow").Column
If Not OK Then Exit Function
pcDate = Cells(Range("DateRow").Row, PlotColumn).Value
CreateTaskShape = 0
If Rows(PlotRow).Hidden Then Exit Function
CreateTaskShape = 1
rHeight = Range("DateRow").Offset(1, 0).RowHeight
cWidth = Range("DateRow").Offset(0, 2).Left - Range("DateRow").Offset(0, 1).Left
StartDate = 1
On Error Resume Next
StartDate = Range("StartDate").Offset(0, 1).Value - Range("StartDate").Value
On Error GoTo 0
Select Case StartDate
Case Is 7: ppDay = cWidth / 30
End Select
StartDate = CDate(Range("DateRow").Offset(0, 1).Value)
If StartDate = MinTaskDuration Then
TaskWidth = (.TaskTime2 - .TaskTime1) * ppDay
Else
TaskWidth = MinTaskDuration * ppDay
End If
TaskHeight = rHeight - 4
End With
If TaskLeftPos maxPos Then Exit Function
If TaskLeftPos + TaskWidth > maxPos Then TaskWidth = maxPos - TaskLeftPos
If TaskTopPos "" Then
tshpName = TaskInfo.TaskIdent
tshpName = AddTextBoxShape(TaskLeftPos, TaskTopPos, TaskWidth, TaskHeight, tshpName, 0, _
0, -1)
If Len(tshpName) > 0 Then
shpCount = shpCount + 1
shpNames(shpCount) = tshpName
End If
End If
If TaskInfo.TaskComplete > 0.001 Then
tshpName = AddTextBoxShape(TaskLeftPos, TaskTopPos, TaskWidth * TaskInfo.TaskComplete, _
TaskHeight, "", TaskBarDoneFGcolor, TaskBarDoneBGcolor, 1)
If Len(tshpName) > 0 Then
shpCount = shpCount + 1
shpNames(shpCount) = tshpName
End If
End If
If TaskInfo.TaskComplete 0 Then
shpCount = shpCount + 1
shpNames(shpCount) = tshpName
End If
End If
If TaskInfo.TaskComment "" And TaskLeftPos + TaskWidth + cWidth * TaskBarCommentSize + 4 _
0 Then
shpCount = shpCount + 1
shpNames(shpCount) = tshpName
End If
End If
Select Case shpCount
Case 2: ActiveSheet.Shapes.Range(Array(shpNames(1), shpNames(2))).Select
Case 3: ActiveSheet.Shapes.Range(Array(shpNames(1), shpNames(2), shpNames(3))).Select
Case 4: ActiveSheet.Shapes.Range(Array(shpNames(1), shpNames(2), shpNames(3), shpNames( _
4))).Select
End Select
If shpCount > 1 Then Selection.ShapeRange.Group.Select
Erase shpNames
Erase shpNames
If shpCount > 0 Then CreateTaskShape = 0
End Function
Private Function AddTextBoxShape(LeftPos As Long, TopPos As Long, _
Width As Long, Height As Long, TextString As String, _
fgColor As Long, bgColor As Long, FillType As Integer) As String
Dim tbfName As String, tbfSize As Integer, NTBS As Shape
Dim strHex As String, R As Integer, G As Integer, B As Integer
On Error Resume Next
tbfName = Range("tdfName").Value
tbfSize = Range("tdfSize").Value
On Error Resume Next
If tbfName = "" Then tbfName = "Arial Narrow"
If tbfSize 0 Then temp.TaskResource = .Cells(R, 1).Value
If Len(.Cells(R, 2).Formula) > 0 Then temp.TaskIdent = .Cells(R, 2).Value
If Len(.Cells(R, 3).Formula) > 0 Then temp.TaskTime1 = .Cells(R, 3).Value
If Len(.Cells(R, 4).Formula) > 0 Then temp.TaskTime2 = .Cells(R, 4).Value
If Len(.Cells(R, 5).Formula) > 0 Then temp.TaskComplete = .Cells(R, 5).Value
If Len(.Cells(R, 6).Formula) > 0 Then temp.TaskComment = .Cells(R, 6).Value
End With
On Error GoTo 0
With temp
If .TaskTime1 >= 0 And .TaskTime2 >= 0 Then
If .TaskTime2 1 Then .TaskComplete = 1
End With
ReadTaskInfo = temp
End Function
Private Sub DeleteAllShapes(ws As Worksheet)
Dim i As Long
If ws Is Nothing Then Exit Sub
With ws
For i = .Shapes.Count To 1 Step -1
On Error Resume Next
.Shapes(i).Delete
On Error GoTo 0
Next i
End With
End Sub
Sub FormatTaskChartSheet()
Dim LRN As Integer, LCN As Integer, R As Integer, c As Integer, td As Long, rt As Integer
Dim ChartOption As Integer
If Application.International(xlCountrySetting) = 47 Then
If MsgBox("Er du sikker på at du vil tegne opp kantlinjene på nytt ?", vbQuestion + _
vbYesNo, ThisWorkbook.Name) = vbNo Then Exit Sub
Else
If MsgBox("Do you really want to recreate the border lines?", vbQuestion + vbYesNo, _
ThisWorkbook.Name) = vbNo Then Exit Sub
End If
Application.ScreenUpdating = False
Application.StatusBar = "Creating new border lines in " & ActiveSheet.Name & "..."
LRN = LastRowNumber(1, True)
LCN = LastColumnNumber(Range("DateRow").Row, True)
Range(Cells(1, 1), Cells(LRN, LCN)).Select
AddBorderLines xlLineStyleNone, xlThin, xlAutomatic, False
Range(Cells(2, 1), Cells(LRN, 1)).Select
AddBorderLines xlContinuous, xlThin, xlAutomatic, False
For c = 2 To LRN
Range(Cells(c, 1), Cells(c, LCN)).Select
AddBorderLines xlContinuous, xlMedium, xlAutomatic, True
Next c
Range(Cells(Range("DateRow").Row, 1), Cells(Range("DateRow").Row, LCN)).Select
AddBorderLines xlContinuous, xlMedium, xlAutomatic, True
td = 1
On Error Resume Next
td = Range("StartDate").Offset(0, 1).Value - Range("StartDate").Value
On Error GoTo 0
Select Case td
Case Is 7: ChartOption = 3 ' Monate
End Select
R = Range("DateRow").Column + 1
For c = R To LCN
Application.StatusBar = "Formatting dates " & Format(c / (LCN - 1), "0 %") & "..."
If Cells(2, c).Formula Empty Then
Select Case ChartOption
Case 1: 'Tage
rt = xlNone
If (c - R) Mod 7 = 0 Then
rt = xlMedium
Else
rt = xlHairline
End If
Case 2: ' Wochen
rt = xlNone
If (c - R) Mod 4 = 0 Then
rt = xlMedium
Else
rt = xlHairline
End If
Case 3: ' Monate
td = Range("DateRow").Offset(0, c - 1).Value
rt = xlNone
Select Case Month(td)
Case 1: rt = xlMedium
Case 4, 7, 10: rt = xlThin
Case Else: rt = xlHairline
End Select
End Select
Range(Cells(2, c), Cells(LRN, c)).Select
If rt = xlLineStyleNone Then
AddBorderLine xlEdgeLeft, rt, xlHairline, xlAutomatic
Else
AddBorderLine xlEdgeLeft, xlContinuous, rt, xlAutomatic
End If
End If
Next c
' nicht benötigte Zeilen löschen
Rows(LRN + 1 & ":" & Rows.Count).Delete
Range("DateRow").Offset(0, 1).Select
Application.StatusBar = False
End Sub
Private Sub AddBorderLines(intLineStyle As Integer, intLineWidth As Integer, _
intLineColor As Integer, blnAddBorder As Boolean)
' intLineStyle =xlLineStyleNone, xlContinuous...
' intLineWidth =xlHairline, xlThin, xlMedium, xlThick
' intLineColor =xlAutomatic or a number
AddBorderLine xlEdgeTop, intLineStyle, intLineWidth, intLineColor
AddBorderLine xlEdgeRight, intLineStyle, intLineWidth, intLineColor
AddBorderLine xlEdgeLeft, intLineStyle, intLineWidth, intLineColor
AddBorderLine xlEdgeBottom, intLineStyle, intLineWidth, intLineColor
If Not blnAddBorder Then ' lag kantlinjer innenfor rammen også
AddBorderLine xlInsideVertical, intLineStyle, intLineWidth, intLineColor
AddBorderLine xlInsideHorizontal, intLineStyle, intLineWidth, intLineColor
End If
End Sub
Private Sub AddBorderLine(intBorder As Integer, intStyle As Integer, intWidth As Integer, _
intColor As Integer)
' intBorder =xlEdgeTop,xlEdgeRight, xlEdgeLeft, xlEdgeBottom, xlInsideVertical, _
xlInsideHorizontal
' intStyle =xlLineStyleNone, xlContinuous...
' intWidth =xlThin, xlMedium, xlThick
' intColor =xlAutomatic or a number
On Error Resume Next
With Selection.Borders(intBorder)
.LineStyle = intStyle
If .LineStyle xlLineStyleNone Then
.Weight = intWidth
.ColorIndex = intColor
End If
End With
On Error GoTo 0
End Sub
Private Function LastRowNumber(Column As Integer, Hidden As Boolean) As Long
If Len(Cells(Rows.Count, Column).Formula) = 0 Then
LastRowNumber = Cells(Rows.Count, Column).End(xlUp).Row
Else
LastRowNumber = Rows.Count
Exit Function
End If
If Hidden Then
Do While Rows(LastRowNumber + 1).EntireRow.Hidden And LastRowNumber = sminx And minx = sminx And maxx