Sub KoepfeAlle()
Dim I, j, k, ID_number, column_widths, manager_name, r_row, c_col
Application.ScreenUpdating = False
With Sheets("Aux")
For I = 3 To .Range("AN" & Rows.count).End(xlUp).Row
If InStr(1, ID_number, Split(.Range("Q" & I), " ")(0)) = 0 And Not .Range("Q" & I) = "n/a" Then
ID_number = ID_number & "," & Split(.Range("Q" & I), " ")(0)
End If
Next
ID_number = Split(Right(ID_number, Len(ID_number) - 1), ",")
End With
For I = LBound(ID_number) To UBound(ID_number)
With Sheets.Add
.Name = ID_number(I) & "_Koepfe Alle"
.Columns(1).ColumnWidth = 3
.Columns(2).ColumnWidth = 20
.Columns(3).ColumnWidth = 22
.Columns(4).ColumnWidth = 12
.Columns(5).ColumnWidth = 20
.Columns(6).ColumnWidth = 9
.Range("B2") = "Team"
.Range("C2") = "FK"
.Range("D2") = "EmplID"
.Range("E2") = "Name"
.Range("F2") = "'01/14"
ActiveWindow.DisplayGridlines = False
End With
Next I
For I = 4 To Sheets("Vergütungsdaten_M").Range("K" & Rows.count).End(xlUp).Row
If Not Sheets("Vergütungsdaten_M").Range("D" & I) = 41639 And Sheets("Vergütungsdaten_M").Range("CT" & I) = "aktiv" Then
If Not Sheets("Vergütungsdaten_M").Range("CP" & I) = "n/a" And Not Sheets("Vergütungsdaten_M").Range("CO" & I) = "n/a" Then
If Not Sheets("Vergütungsdaten_M").Range("K" & I) = "" And Not Sheets("Vergütungsdaten_M").Range("J" & I) = "" Then
With Sheets(Split(WorksheetFunction.Index(Sheets("Aux").Range("Q:Q"), _
WorksheetFunction.Match(Sheets("Vergütungsdaten_M").Range("K" & I), _
Sheets("Aux").Range("T:T"), 0)), " ")(0) & "_Koepfe Alle")
manager_name = WorksheetFunction.Index(Sheets("Aux").Range("R:R"), _
WorksheetFunction.Match(Sheets("Vergütungsdaten_M").Range("K" & I), _
Sheets("Aux").Range("T:T"), 0))
If Sheets("Vergütungsdaten_M").Range("D" & I) = 41670 Then '41639
If Not Sheets("Vergütungsdaten_M").Range("Q" & I) = 0 Then
.Range("B" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("CP" & I)
.Range("C" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("CO" & I)
.Range("D" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("F" & I)
.Range("E" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("J" & I)
.Range("F" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("Q" & I)
End If
Else
If WorksheetFunction.CountIf(.Rows(2), Right("0" & Month(Sheets("Vergütungsdaten_M").Range("D" & I)) & "/" & Right(Year(Sheets("Vergütungsdaten_M").Range("D" & I)), 2), 5)) = 0 Then
.Cells(2, Columns.count).End(xlToLeft).Offset(0, 1).ColumnWidth = 9
.Cells(2, Columns.count).End(xlToLeft).Offset(0, 1) = "'" & Right("0" & Month(Sheets("Vergütungsdaten_M").Range("D" & I)) & "/" & Right(Year(Sheets("Vergütungsdaten_M").Range("D" & I)), 2), 5)
.Cells(2, Columns.count).End(xlToLeft).Offset(0, 1).ColumnWidth = 9
.Cells(2, Columns.count).End(xlToLeft).Offset(0, 1) = "Delta VM"
.Cells(2, Columns.count).End(xlToLeft).Offset(0, 1).ColumnWidth = 14.14
.Cells(2, Columns.count).End(xlToLeft).Offset(0, 1) = "Effekt"
End If
c_col = WorksheetFunction.Match(Right("0" & Month(Sheets("Vergütungsdaten_M").Range("D" & I)) & "/" & Right(Year(Sheets("Vergütungsdaten_M").Range("D" & I)), 2), 5), .Rows(2), 0)
r_row = Evaluate("=MAX(IF('" & .Name & "'!C1:C" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!CO" & I & ",ROW(A1:A" & .Range("D" & Rows.count).End(xlUp).Row & "),0)*if('" & .Name & "'!B1:B" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!CP" & I & ",1,0)*if('" & .Name & "'!D1:D" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!F" & I & ",1,0))")
If r_row = 0 Then
.Range("B" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("CP" & I)
.Range("C" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("CO" & I)
.Range("D" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("F" & I)
.Range("E" & Rows.count).End(xlUp).Offset(1, 0) = Sheets("Vergütungsdaten_M").Range("J" & I)
r_row = Evaluate("=MAX(IF('" & .Name & "'!C1:C" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!CO" & I & ",ROW(A1:A" & .Range("D" & Rows.count).End(xlUp).Row & "),0)*if('" & .Name & "'!B1:B" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!CP" & I & ",1,0)*if('" & .Name & "'!D1:D" & .Range("D" & Rows.count).End(xlUp).Row & "='Vergütungsdaten_M'!F" & I & ",1,0))")
End If
.Cells(r_row, c_col) = Sheets("Vergütungsdaten_M").Range("Q" & I)
.Cells(r_row, c_col + 2) = Sheets("Vergütungsdaten_M").Range("BZ" & I)
End If
End With
End If
End If
End If
Next I
For I = LBound(ID_number) To UBound(ID_number)
With Sheets(ID_number(I) & "_Koepfe Alle")
.Select
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("B3:B" & .Range("B3").End(xlDown).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
.Sort.SortFields.Add Key:=.Range("C3:C" & .Range("C3").End(xlDown).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
.Sort.SortFields.Add Key:=.Range("E3:E" & .Range("E3").End(xlDown).Row), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
.Sort.SetRange .Range("B3:" & .Cells(.Range("B2").End(xlDown).Row, .Range("B2").End(xlToRight).Column).Address)
.Sort.Apply
.Range("A3:A" & .Range("B" & Rows.count).End(xlUp).Row).Formula = "=IF(B3=B2,"""",B3)"
.Range("B3:B" & .Range("B" & Rows.count).End(xlUp).Row).Value = Range("A3:A" & Range("B" & Rows.count).End(xlUp).Row).Value
.Range("A3:A" & .Range("C" & Rows.count).End(xlUp).Row).Formula = "=IF(AND(B3="""",C3=C2),"""",C3)"
.Range("C3:C" & .Range("C" & Rows.count).End(xlUp).Row).Value = Range("A3:A" & Range("C" & Rows.count).End(xlUp).Row).Value
.Columns(1).Value = ""
j = 3
Do Until .Range("D" & j) = ""
If Not .Range("B" & j) = "" Then
.Rows(j).Insert
.Range("B" & j) = .Range("B" & j + 1)
.Range("B" & j + 1) = ""
End If
j = j + 1
Loop
j = 3
Do Until .Range("D" & j) = "" And .Range("B" & j) = ""
If Not .Range("C" & j) = "" Then
.Rows(j).Insert
.Range("C" & j) = .Range("C" & j + 1)
.Range("C" & j + 1) = ""
End If
j = j + 1
Loop
.Columns(8).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]-RC[-2]"
For k = 9 To .Cells(2, Columns.count).End(xlToLeft).Column
If Cells(2, k) = "Delta VM" Then
.Columns(k).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=RC[-1]-RC[-4]"
End If
Next k
.Rows(1).Value = ""
For j = 3 To .Range("E" & Rows.count).End(xlUp).Row
If Not .Range("B" & j) = "" Then
Cells(j, 6).FormulaR1C1 = "=SUMIF(R[1]C4:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 2).End(xlDown).Row - j - 1) & "]C4,""<>""&"""",R[1]C:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 2).End(xlDown).Row - j - 1) & "]C)"
For k = 7 To .Cells(2, Columns.count).End(xlToLeft).Column Step 3
Cells(j, k).Resize(1, 2).FormulaR1C1 = "=SUMIF(R[1]C4:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 2).End(xlDown).Row - j - 1) & "]C4,""<>""&"""",R[1]C:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 2).End(xlDown).Row - j - 1) & "]C)"
Next k
ElseIf Not .Range("C" & j) = "" Then
Cells(j, 6).FormulaR1C1 = "=SUMIF(R[1]C4:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 3).End(xlDown).Row - j - 1) & "]C4,""<>""&"""",R[1]C:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 3).End(xlDown).Row - j - 1) & "]C)"
For k = 7 To .Cells(2, Columns.count).End(xlToLeft).Column Step 3
Cells(j, k).Resize(1, 2).FormulaR1C1 = "=SUMIF(R[1]C4:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 3).End(xlDown).Row - j - 1) & "]C4,""<>""&"""",R[1]C:R[" & WorksheetFunction.Min(Cells(Rows.count, 4).End(xlUp).Row, .Cells(j, 3).End(xlDown).Row - j - 1) & "]C)"
Next k
End If
Next j
r_row = .Range("D" & Rows.count).End(xlUp).Offset(1, 0).Row
.Range("B" & r_row) = "Summe"
.Range("F" & r_row).Formula = "=SUMIF(B3:B" & r_row - 1 & ",""<>""&"""",F3:F" & r_row - 1 & ")"
For j = 7 To Cells(2, Columns.count).End(xlToLeft).Column Step 3
.Cells(r_row, j).Resize(1, 2).FormulaR1C1 = "=SUMIF(R3C2:R" & r_row - 1 & "C2,""<>""&"""",R3C[]:R" & r_row - 1 & "C[])"
Next j
.Cells.RowHeight = 12.75
.Rows(2).RowHeight = 25.5
End With
With Sheets(ID_number(I) & "_Koepfe Alle").Range("B2:" & Sheets(ID_number(I) & "_Koepfe Alle").Cells(2, Columns.count).End(xlToLeft).Address)
.Interior.ColorIndex = 23
.Font.Bold = True
.Font.ColorIndex = 2
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
With Intersect(Sheets(ID_number(I) & "_Koepfe Alle").UsedRange, Sheets(ID_number(I) & "_Koepfe Alle").Range("B2:" & Cells(Rows.count, Columns.count).Address))
.Borders(xlInsideHorizontal).LineStyle = xlContinuous
.Borders(xlInsideVertical).LineStyle = xlContinuous
.BorderAround xlContinuous
End With
count = 4
Do Until count = Rows.count
With Sheets(ID_number(I) & "_Koepfe Alle").Range("C" & count & ":" & Sheets(ID_number(I) & "_Koepfe Alle").Cells(count, Columns.count).End(xlToLeft).Offset(0, 1).Address)
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = -0.149998474074526
.Interior.PatternTintAndShade = 0
.Font.Bold = True
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
r_row = Sheets(ID_number(I) & "_Koepfe Alle").Range("C" & count).End(xlDown).Row
Sheets(ID_number(I) & "_Koepfe Alle").Range("C" & count + 1 & ":C" & r_row - 1).Borders(xlInsideHorizontal).LineStyle = xlNone
count = r_row
Loop
count = 3
Do Until count = Rows.count
With Sheets(ID_number(I) & "_Koepfe Alle").Range("B" & count & ":" & Sheets(ID_number(I) & "_Koepfe Alle").Cells(count, Columns.count).End(xlToLeft).Offset(0, 1).Address)
.Interior.Pattern = xlSolid
.Interior.PatternColorIndex = xlAutomatic
.Interior.ThemeColor = xlThemeColorDark1
.Interior.TintAndShade = -0.149998474074526
.Interior.PatternTintAndShade = 0
.Font.Bold = True
.VerticalAlignment = xlCenter
.HorizontalAlignment = xlCenter
End With
r_row = Sheets(ID_number(I) & "_Koepfe Alle").Range("B" & count).End(xlDown).Row
Sheets(ID_number(I) & "_Koepfe Alle").Range("B" & count + 1 & ":B" & r_row - 1).Borders(xlInsideHorizontal).LineStyle = xlNone
count = r_row
Loop
For count = 3 To Range("B" & Rows.count).End(xlUp).Row
If Not Range("B" & count) = "" Then
With Sheets(ID_number(I) & "_Koepfe Alle").Range("B" & count & ":E" & count)
.Borders(xlInsideVertical).LineStyle = xlNone
.BorderAround xlContinuous
End With
ElseIf Not Range("C" & count) = "" Then
With Sheets(ID_number(I) & "_Koepfe Alle").Range("C" & count & ":E" & count)
.Borders(xlInsideVertical).LineStyle = xlNone
.BorderAround xlContinuous
End With
End If
Next count
Sheets(ID_number(I) & "_Koepfe Alle").Range("D" & Sheets(ID_number(I) & "_Koepfe Alle").Range("D" & Rows.count).End(xlUp).Row + 2 & ":D" & Rows.count).EntireRow.Delete
Next I
Application.ScreenUpdating = True
MsgBox ("Koepfe Alle erfolgreich erstellt!")
'Call KoepfeDetail
End Sub
Bookmarks