Option Explicit
'Worksheets'
Dim wksCombustor As Worksheet, wksCompressor As Worksheet, wksGT_Integration As Worksheet, _
wksTermine As Worksheet, wksMakro As Worksheet
'Letzte Zeilen von Worksheets'
Dim LzWksCombustor As Long, LzWksCompressor As Long, LzWksGT_Integration As Long
'Variabeln'
Dim X_Wks As Worksheet
Dim X_LzWks As Long
\pre>
Sub Initial(X_Wks, X_LzWks)
With X_Wks
'Spaltenbreite'
Columns("A:A").ColumnWidth = 4.5
Columns("B:D").ColumnWidth = 42
Columns("E:J").ColumnWidth = 15
Columns("L:L").ColumnWidth = 15
Columns("K:K").ColumnWidth = 15
'Zeilenhöhe'
Range("1:1").EntireRow.RowHeight = 70
Range("2:3").EntireRow.RowHeight = 40
Range("4:500").EntireRow.RowHeight = 20
'Initialisierung'
With Range(Cells(X_LzWks + 1, 1), Cells(500, 12))
.ClearContents
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 1
End With
End With
End Sub
\pre>
Private Sub Dates(X_Wks, X_LzWks)
Dim jump As Long
Dim i As Long, last As Long
jump = 1
'Earliest and Latest date'
For i = 8 To 10
With X_Wks
.Range(.Cells(4, i), .Cells(X_LzWks, i)).copy
wksMakro.Cells(jump, 14).PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:= _
False, Transpose:=False
jump = jump + X_LzWks
End With
Next
With wksMakro
.Range("N1:N500").Sort Key1:=.Columns("N"), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=True, Orientation:= _
xlTopToBottom
last = wksMakro.Cells(Rows.Count, 14).End(xlUp).row
If .Cells(1, 14).Value = "" Then
.Cells(1, 10).Value = .Cells(9, 19).Value
Else: .Cells(1, 10).Value = .Cells(1, 14).Value
X_Wks.Cells(1, 10).Value = wksMakro.Cells(1, 10).Value
End If
If .Cells(last, 14).Value = "" Then
.Cells(1, 12).Value = .Cells(10, 19).Value
Else: .Cells(1, 12).Value = .Cells(last, 14).Value
X_Wks.Cells(1, 12).Value = wksMakro.Cells(1, 12).Value
End If
End With
End Sub
\pre>
Private Sub Format(X_Wks, X_LzWks)
Dim index As Variant, Titel As Variant
Dim i As Long
Dim j As Byte
Dim Check As Boolean
With X_Wks
'Titel'
X_Wks.Cells(1, 1).Resize(2, 12).Value = wksMakro.Cells(1, 1).Resize(2, 12).Value 'Headers'
X_Wks.Cells(3, 9).Value = wksMakro.Cells(3, 9).Value
With Range(Cells(1, 1), Cells(4, 12)).Font
.Size = 12
.Bold = True
.Superscript = False
.Underline = False
.Strikethrough = False
.Italic = False
.ColorIndex = 1
End With
Cells(1, 2).Font.Size = 25
Cells(3, 2).Font.Size = 16
Cells(3, 9).Font.Italic = True
'Schrift'
With Range(Cells(4, 1), Cells(X_LzWks, 12)).Font
.Size = 12
.Bold = False
.Superscript = False
.Underline = False
.Strikethrough = False
.Italic = False
.ColorIndex = 1
End With
'Rahmen'
For index = xlDiagonalDown To xlInsideHorizontal
With Range(Cells(4, 1), Cells(500, 12)).Borders(index)
.LineStyle = xlNone
End With
Next
For index = xlEdgeTop To xlInsideHorizontal
With Range(Cells(4, 1), Cells(X_LzWks, 12)).Borders(index)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
Next
For index = xlEdgeLeft To xlEdgeRight
With Range(Cells(4, 1), Cells(X_LzWks, 12)).Borders(index)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Next
For index = xlEdgeLeft To xlEdgeRight
With Range(Cells(4, 8), Cells(X_LzWks, 10)).Borders(index)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = xlAutomatic
End With
Next
'Füllfarbe'
Range(Cells(4, 1), Cells(X_LzWks, 12)).Interior.ColorIndex = 2
Range(Cells(1, 1), Cells(X_LzWks, 1)).Interior.ColorIndex = 35
Range(Cells(1, 1), Cells(3, 12)).Interior.ColorIndex = 35
For i = 4 To X_LzWks
For j = 8 To 10
If IsEmpty(Cells(i, j)) Then
Cells(i, j).Interior.ColorIndex = 2
Else: Cells(i, j).Interior.ColorIndex = 36
End If
Next
Next
Cells(1, 10).Interior.ColorIndex = 36
Cells(1, 12).Interior.ColorIndex = 36
Check = True
Do
If Cells(3, 2).Value = "" Then
Titel = InputBox("No input for Titel")
Cells(3, 2).Value = "" & Titel
Check = True
End If
Check = False
Loop Until Check = False
End With
End Sub
\pre>
Sub save_WksCombustor()
Set wksMakro = Worksheets("Makro")
Set wksCombustor = Worksheets("Combustor")
LzWksCombustor = wksCombustor.Cells(Rows.Count, 1).End(xlUp).row
wksCombustor.Unprotect
wksMakro.Unprotect
Call Initial(wksCombustor, LzWksCombustor) 'Wks Grundformatierung'
Call Dates(wksCombustor, LzWksCombustor) 'Earliest Date / Latest Date'
Call Format(wksCombustor, LzWksCombustor) 'Wks EndFormatierung'
wksCombustor.Protect
wksMakro.Protect
End Sub
Sub save_WksCompressor()
Set wksMakro = Worksheets("Makro")
Set wksCompressor = Worksheets("Compressor")
LzWksCompressor = wksCompressor.Cells(Rows.Count, 1).End(xlUp).row
wksCompressor.Unprotect
wksMakro.Unprotect
Call Initial(wksCompressor, LzWksCompressor) 'Wks Grundformatierung'
Call Dates(wksCompressor, LzWksCompressor) 'Earliest Date / Latest Date'
Call Format(wksCompressor, LzWksCompressor) 'Wks EndFormatierung'
wksCompressor.Protect
wksMakro.Protect
End Sub
Sub save_WksGT_Integration()
Set wksGT_Integration = Worksheets("GT_Integration")
Set wksMakro = Worksheets("Makro")
LzWksGT_Integration = wksGT_Integration.Cells(Rows.Count, 1).End(xlUp).row
wksGT_Integration.Unprotect
wksMakro.Unprotect
Call Initial(wksGT_Integration, LzWksGT_Integration) 'Wks Grundformatierung'
Call Dates(wksGT_Integration, LzWksGT_Integration) 'Earliest Date / Latest Date'
Call Format(wksGT_Integration, LzWksGT_Integration) 'Wks EndFormatierung'
wksGT_Integration.Protect
wksMakro.Protect
xx
End Sub
Sub edit_wksCombustor()
Set wksCombustor = Worksheets("Combustor")
wksCombustor.Unprotect
End Sub
Sub edit_wksCompressor()
Set wksCompressor = Worksheets("Compressor")
wksCompressor.Unprotect
End Sub
Sub edit_wksGT_Integration()
Set wksGT_Integration = Worksheets("GT_Integration")
wksGT_Integration.Unprotect
End Sub
So jetzt passt... ziemlich peinlicher Fehler hab sicher 20 mal in(i)tial angeschaut und den Tippfehler nicht gesehen, naja jetzt klappts....
Ist das so ok, oder was für gute Tipps wie Daniel's gibts noch?
Danke viel mal! Gruss Nicolas