2 functions+1code=1code aber wie?

Sub berechnung () Worksheets("gesamtplanung").Activate With ActiveSheet Dim loLetzte As Long Dim loI As Long loLetzte = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count) For loI = 2 To loLetzte Cells(loI, 14).FormulaLocal = "=WENN(Arbeitstage!$J$7=WAHR;atc1(c" & loI & ";d" & loI & ";Arbeitstage!funftagewochenamen);(WENN(Arbeitstage!$K$7=WAHR;atc(c" & loI & ";d" & loI & ";Arbeitstage!sechstagewochenamen);o" & loI & ")))" Cells(loI, 14).NumberFormat = "General" Range(Cells(loI, 14), Cells(loI, 15)).HorizontalAlignment = xlCenter Next loI Range(Cells(loI, 14), Cells(loI, 15)).Font.ColorIndex = 3 End With 'Worksheets("tabelle3").Activate End Sub

Function ATC1(Start, Ende, FT) Dim C As Range ATC1 = 0 For j = Start To Ende If (Weekday(j) <> 1) And (Weekday(j) <> 7) Then ATC1 = ATC1 + 1 Next For j = 1 To FT.Rows.Count Set C = FT.Cells(j, 1) If C >= Start And C <= Ende Then If (Weekday(C) <> 1) And (Weekday(C) <> 7) Then ATC1 = ATC1 - 1 End If Next j End Function

Function ATC(Start, Ende, FT) Dim C As Range Dim a%, b%, i% a = 8 - Weekday(Start) b = Weekday(Ende) - 1 ATC = (Ende - Start) - (a + b) ATC = ATC - (ATC / 7) ATC = ATC + a + b If Weekday(Start) = 1 Then ATC = ATC - 1 For i = 1 To FT.Rows.Count Set C = FT.Cells(i, 1) If C >= Start And C <= Ende Then If Weekday(C) <> 1 Then ATC = ATC - 1 End If Next i End Function

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo selo,
wenn ich Dich also richtig verstanden habe, willst Du nicht mehr die Formeln in die Zellen schreiben, sondern das Ergebnis in der Sub selbst berechnen und dann nur noch das Ergebis in die Zellen schreiben. Hier mein 1. Versuch:


Sub beRechnung()
'first trying by Luschi
Dim wb As Workbook, _
ws1 As Worksheet, ws2 As Worksheet, _
rg1 As Range, rg2 As Range, _
loLetzte As Long, loI As Long, _
nArt As Integer, n1 As Long, n2 As Long, _
v As Variant, _
xlApp As Application
Set xlApp = Application
xlApp.ScreenUpdating = False
xlApp.Calculation = xlCalculationManual
xlApp.EnableEvents = False
Set wb = ThisWorkbook
Set ws1 = wb.Worksheets("gesamtplanung")
Set ws2 = wb.Worksheets("Arbeitstage")
ws1.Activate
loLetzte = IIf(IsEmpty(ws1.Cells(ws1.Rows1.Count, 2)), _
ws1.Cells(ws1.Rows1.Count, 2).End(xlUp).Row, ws1.Rows1.Count)
For loI = 2 To loLetzte
If (ws2.Range("J7") Or ws2.Range("K7")) Then
Set rg1 = ws1.Range("C" & loI)
Set rg2 = ws1.Range("D" & loI)
If ws2.Range("J7") Then
nArt = 1
Set rg3 = wb.Names("funftagewochenamen").RefersToRange
Else
nArt = 2
Set rg3 = wb.Names("sechstagewochenamen").RefersToRange
End If
Else
nArt = 2
Set rg3 = ws1.Range("O" & loI)
End If
Select Case nArt
Case 1:    n1 = ATC1(rg1.Value, rg2.Value, rg3)
Case 2:    n1 = ATC(rg1.Value, rg2.Value, rg3)
Case 3:    v1 = rg3.Value
End Select
If nArt <= 2 Then
ws1.Cells(loI, 14).Value = n1
Else
ws1.Cells(loI, 14).Value = v1
End If
ws1.Cells(loI, 14).NumberFormat = "General"
ws1.Range(Cells(loI, 14), Cells(loI, 15)).HorizontalAlignment = xlCenter
ws1.Range(Cells(loI, 14), Cells(loI, 15)).Font.ColorIndex = 3
Set rg1 = Nothing
Set rg2 = Nothing
Set rg3 = Nothing
Next loI
'wb.Worksheets("tabelle3").Activate
Set ws1 = Nothing
Set ws2 = Nothing
Set wb = Nothing
xlApp.Calculation = xlCalculationAutomatic
xlApp.EnableEvents = True
xlApp.ScreenUpdating = True
Set xlApp = Nothing
End Sub
Private Function ATC1(start As start, Ende As Date, ByRef FT As Range)
Dim C As Range, xZahl As Integer, j As Date, k As Long
xZahl = 0
For j = start To Ende
If (Weekday(j) <> 1) And (Weekday(j) <> 7) Then
xZahl = xZahl + 1
End If
Next
For k = 1 To FT.Rows.Count
Set C = FT.Cells(k, 1)
If C.Value >= start And C.Value <= Ende Then
If (Weekday(C.Value) <> 1) And (Weekday(C.Value) <> 7) Then
xZahl = xZahl - 1
End If
End If
Next j
Set C = Nothing
ATC1 = xZahl
End Function
Private Function ATC(start As Date, Ende As Date, ByRef FT As Range)
Dim C As Range, _
a%, b%, i%, xZahl As Integer
a = 8 - Weekday(start)
b = Weekday(Ende) - 1
xZahl = (Ende - start) - (a + b)
xZahl = xZahl - (xZahl / 7)
xZahl = xZahl + a + b
If Weekday(start) = 1 Then
xZahl = xZahl - 1
End If
For i = 1 To FT.Rows.Count
Set C = FT.Cells(i, 1)
If C.Value >= start And C.Value <= Ende Then
If Weekday(C.Value) <> 1 Then
xZahl = xZahl - 1
End If
End If
Next i
Set C = Nothing
ATC = xZahl
End Function

Konnte den Code aber nicht testen, weil ich die Range-Bereiche für "funftagewochenamen" und "sechstagewochenamen" nicht habe.
Gruß von Luschi
aus klein-Paris

Beliebteste Forumthreads (12 Monate)

2 functions+1code=1code aber wie?

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread