Option Explicit
Sub DatenÜbertragen()
Dim AV, LC&(1), R&, I%, TS$, FS$, TSum#
fLC LC, 5, 7, , , Sheets("Auswertung")
AV = Sheets("Auswertung").Range("E1:F" & LC(0)).Value
For R = LBound(AV) To UBound(AV)
If AV(R, 1) = "Kostenstellen" Then
For I = 1 To 5
If R + I > UBound(AV) Then Exit For
TSum = TSum + AV(R + I, 2)
Next
For I = 1 To 5
If R + I > UBound(AV) Then Exit For
TS = AV(R + I, 2)
If TS = "" Then Exit For
TS = Application.WorksheetFunction.Round(TS / TSum * 100, 2)
If TS <> "" Then
If FS = "" Then
FS = AV(R + I, 1) & " [" & TS & " %]"
Else
FS = FS & ";" & AV(R + I, 1) & " [" & TS & " %]"
End If
End If
Next
If FS <> "" Then
Sheets("MSP").Range("J" & R).Value = FS
FS = ""
End If
End If
Next
End Sub
Private Sub fLC( _
ByRef LC&(), _
Optional ByVal S2%, _
Optional ByVal E2%, _
Optional ByVal S1&, _
Optional ByVal E1&, _
Optional tSh As Worksheet, _
Optional WB As Workbook _
)
Dim C%, R&, TV&, TV2&
If E1 = 0 Then E1 = Rows.Count
If E2 = 0 Then E2 = Columns.Count
If S1 = 0 Then S1 = 1
If S2 = 0 Then S2 = 1
If tSh Is Nothing Then Set tSh = ActiveSheet
If Not WB Is Nothing Then WB.Activate
With tSh
TV2 = .Cells(S1, E2).End(xlToLeft).Column
For C = S2 To E2
TV = .Cells(E1, C).End(xlUp).Row
If TV > LC(0) Then LC(0) = TV
If TV <> 1 And C > TV2 Then LC(1) = C
Next
If LC(1) = 0 Then LC(1) = TV2
End With
End Sub