AW: VBA - Excel ergänzt Formel selbstständig
19.09.2022 12:46:28
MARTHoss_R
Den gesamtes Code hier einzustellen wird schwierig, da muss ich einiges bereinigen.
Aber das Unterprogramm für die Auswertung, kann ich schon hier einstellen.
Geht sicher auch kürzer, aber ich muss immer im Hinterkopf haben, dass mein Vertreter nichts mit VBA am Hut hat und ich die Makros so aufsetzen muss, dass er im Notfall nachvollziehen kann, was getan werden soll.
Sub Auswertung_Teams(ByVal ws_act As Worksheet, i_lstrow As Integer, i_lstcol As Integer)
'Variablen dimensionieren
Dim arr_teamrng() As String
Dim str_pth_bd As String
Dim str_teamrng As String
Dim str_formula As String
Dim i_lstrow_bd As Integer
Dim i_col As Integer
Dim i_cnt As Integer
Dim i_row As Integer
Dim i_anzteammitgl As Integer
'Überschriften einfügen und formatieren
'Schriftgröße
ws_act.Cells(i_lstrow + 6, 7).Font.Size = 8
ws_act.Cells(i_lstrow + 6, 8).Font.Size = 8
ws_act.Cells(i_lstrow + 6, 9).Font.Size = 8
'Schrift kursiv
ws_act.Cells(i_lstrow + 6, 7).Font.Italic = True
ws_act.Cells(i_lstrow + 6, 8).Font.Italic = True
ws_act.Cells(i_lstrow + 6, 9).Font.Italic = True
'Schrift fett
ws_act.Cells(i_lstrow + 6, 7).Font.Bold = True
ws_act.Cells(i_lstrow + 6, 8).Font.Bold = True
ws_act.Cells(i_lstrow + 6, 9).Font.Bold = True
'Textausrichtung in der Zelle
ws_act.Cells(i_lstrow + 6, 7).HorizontalAlignment = xlRight
ws_act.Cells(i_lstrow + 6, 8).HorizontalAlignment = xlLeft
ws_act.Cells(i_lstrow + 6, 9).HorizontalAlignment = xlLeft
'Bezeichnung einfügen
ws_act.Cells(i_lstrow + 6, 7).Value = "Team"
ws_act.Cells(i_lstrow + 6, 8).Value = "Kb"
ws_act.Cells(i_lstrow + 6, 9).Value = "MA"
'Formeln einfügen
'in Spalte N (14) Formel eintragen
i_col = 14
'Variablen aus Blatt: "Basisdaten" befüllen
str_pth_bd = ThisWorkbook.Sheets("Basisdaten").Name & "!"
i_lstrow_bd = ThisWorkbook.Sheets("Basisdaten").Cells(Rows.Count, 15).End(xlUp).Row
'alle Teams in "Basisdaten" durchlaufen
For i_cnt = 3 To i_lstrow_bd
'Zellverbund setzen
ws_act.Range(ws_act.Cells(i_lstrow + i_cnt + 4, 5), ws_act.Cells(i_lstrow + i_cnt + 4, 7)).Merge
'Schriftgröße
ws_act.Range(ws_act.Cells(i_lstrow + i_cnt + 4, 5), ws_act.Cells(i_lstrow + i_cnt + 4, 9)).Font.Size = 8
'Schrift kursiv
ws_act.Range(ws_act.Cells(i_lstrow + i_cnt + 4, 5), ws_act.Cells(i_lstrow + i_cnt + 4, 9)).Font.Italic = True
'Textausrichtung in der Zelle
ws_act.Range(ws_act.Cells(i_lstrow + i_cnt + 4, 5), ws_act.Cells(i_lstrow + i_cnt + 4, 9)).HorizontalAlignment = xlRight
'Einsatzbereich verknüpfen
ws_act.Cells(i_lstrow + i_cnt + 4, 5).Formula = "=" & str_pth_bd & "P" & i_cnt
'Einsatzbereichkürzel verknüpfen
ws_act.Cells(i_lstrow + i_cnt + 4, 8).Formula = "=" & str_pth_bd & "O" & i_cnt
str_teamrng = Empty
'alle Zeilen durchlaufen
For i_row = 7 To i_lstrow
'wenn in Spalte E (Teams-Eintragung) der Einsatzbereich enthalten ist
If InStr(1, ws_act.Cells(i_row, 5).Value, ws_act.Cells(i_lstrow + i_cnt + 4, 8).Value, vbTextCompare) > 0 Then
'wenn Bereich noch leer
If str_teamrng = Empty Then
'Zelle in Bereichsstring übernehmen
str_teamrng = ws_act.Cells(i_row, i_col).Address(True, False)
Else
'Zelle zu Bereichsstring hinzufügen
str_teamrng = str_teamrng & "|" & ws_act.Cells(i_row, i_col).Address(True, False)
End If
End If
Next i_row
'wenn Bereich nicht leer ist
If Not str_teamrng = Empty Then
'Mitarbeiteranzahl je Team verknüpfen
ws_act.Cells(i_lstrow + i_cnt + 4, 9).Formula2 = "=COUNTA(" & Replace(Replace(str_teamrng, "|", ","), f05_Spaltenbuchstabe.Buchstabe(i_col), "$C") & ")"
'Anzahl abwesende Mitarbeiter (Anzahl Einträge in Mitarbeiterzeilen abzüglich 2.Schicht, zeitversetztes / mobiles Arbeiten)
arr_teamrng() = Split(str_teamrng, "|", -1, 1)
'wenn mehr als eine Zelle im String vorhanden ist
If UBound(arr_teamrng(), 1) > 0 Then
'Formelstring leeren
str_formula = Empty
'Array durchlaufen
For i_anzteammitgl = LBound(arr_teamrng(), 1) To UBound(arr_teamrng(), 1)
'wenn erster Wert
If str_formula = Empty Then
'Formelstring erstbefüllen
str_formula = "COUNTIF(" & arr_teamrng(i_anzteammitgl) & ", ""2S""),COUNTIF(" & arr_teamrng(i_anzteammitgl) & ", ""ZV""),COUNTIF(" & arr_teamrng(i_anzteammitgl) & ", ""MA"")"
Else
'Formelstring erweitern
str_formula = str_formula & "," & "COUNTIF(" & arr_teamrng(i_anzteammitgl) & ", ""2S""),COUNTIF(" & arr_teamrng(i_anzteammitgl) & ", ""ZV""),COUNTIF(" & arr_teamrng(i_anzteammitgl) & ", ""MA"")"
End If
Next i_anzteammitgl
'Formelstring vervollständigen
str_formula = "=IF(ZELLE_IM_VERBUND(N$7)=TRUE," & _
"COUNTA(" & Replace(Replace(str_teamrng, "|", ","), f05_Spaltenbuchstabe.Buchstabe(i_col), "$C") & ")," & _
"COUNTA(" & Replace(str_teamrng, "|", ",") & ")-SUM(" & str_formula & "))"
'Formel in Zelle übernehmen
ws_act.Cells(i_lstrow + i_cnt + 4, i_col).Formula = str_formula
'wenn nur eine Zelle im String enthalten ist
Else
'Formel in Zelle übernehmen
ws_act.Cells(i_lstrow + i_cnt + 4, i_col).Formula2 = "=IF(ZELLE_IM_VERBUND(N7)=TRUE," & _
"COUNTA(" & Replace(Replace(arr_teamrng(0), "|", ","), f05_Spaltenbuchstabe.Buchstabe(i_col), "$C") & ")," & _
"COUNTA(" & Replace(arr_teamrng(0), "|", ",") & ")" & _
"-SUM(COUNTIF(" & Replace(arr_teamrng(0), "|", ",") & ", ""2S"")," & _
"COUNTIF(" & Replace(arr_teamrng(0), "|", ",") & ", ""ZV"")," & _
"COUNTIF(" & Replace(arr_teamrng(0), "|", ",") & ", ""MA"")))"
End If
'wenn keine Zelle zum Team gehört
Else
'Null Eintragen
ws_act.Cells(i_lstrow + i_cnt + 4, 9).Value = 0
ws_act.Cells(i_lstrow + i_cnt + 4, i_col).Value = 0
End If
'Bereich leeren
str_teamrng = Empty
'Formeln in benachbarte Zellen übernehmen
ws_act.Range(ws_act.Cells(i_lstrow + 7, i_col), ws_act.Cells(i_lstrow + i_cnt + 3, i_col)).AutoFill _
Destination:=ws_act.Range(ws_act.Cells(i_lstrow + 7, i_col), ws_act.Cells(i_lstrow + i_cnt + 3, i_lstcol)), Type:=xlFillDefault
'Auswertungszeilen gruppieren
ws_act.Rows(i_lstrow + 7 & ":" & i_lstrow + i_cnt + 3).Group
'Variablen leeren
Erase arr_teamrng()
str_pth_bd = Empty
str_teamrng = Empty
str_formula = Empty
i_col = Empty
i_cnt = Empty
i_row = Empty
i_anzteammitgl = Empty
End Sub