Hallo zusammen,

Ich berechne per untenstehenden Code in jeweils zwei Tabellenblättern über mehrere Zeilen und Spalten.

Ich ziehe einen Wert zeilenweise ab (Januar bis Dezember).

Nun sollen jeweils neue Spalten eingetragen werden, welche zwischen den bisherigen Spalten kommen, d.h. Januar, neue Spalte  rechts (Abzug Januar), Februar, neue Spalte rechts (Abzug Feb.) usw....

In den neuen Spalten soll am Ende die Differenz zwischen Ursprungswert und Wert nach Abzug stehen. Der  Wert soll zusätzlich mit jedem Abzug addiert werden.

Beispiel: Januar: 50 Februar: 40 März: 30

Abzug laut Code: 60

Neuer Wert Jan 0 Feb. 30

Abzug Jan: 50  Abzug Feb. 10

Neuer Abzug laut Code: 20

Neuer Wert Jan. 0 Feb. 10

Abzug: Jan. 50 Abzug Februar: 30

Dafür muss aber im untenstehendem Code nur noch jede zweite Spalte angesprochen werden.

Case hat nicht funktioniert.

Jemand eine Idee?

Ben

Sub Überstundenabbauen_Funktion(sg As String)
Dim LeZe As Long
Dim n As Single
Dim i As Single
Dim Dneu As Single
Dim jahr As Integer
Dim ws1, ws2 As String

'jahr = Year(Date)


'ws2 = sg & jahr
'ws1 = sg & (jahr - 1)
ws1 = sg & "2017"
ws2 = sg & "2018"


LeZe = ThisWorkbook.Worksheets(ws2).Cells(Rows.Count, 4).End(xlUp).Row

For n = 4 To LeZe 'Zeilen
    Dneu = Worksheets(ws2).Cells(n, 4)
        For i = 5 To 18 ' Spalten E bis R
            If Dneu <= Worksheets(ws1).Cells(n, i) Then
               Worksheets(ws1).Cells(n, i) = Worksheets(ws1).Cells(n, i) - Dneu
               Dneu = 0
            Else
               Dneu = Dneu - Worksheets(ws1).Cells(n, i)
               Worksheets(ws1).Cells(n, i) = 0
            End If
        Next i
      
      
      
      If Dneu = 0 Then
        Worksheets(ws2).Cells(n, 4) = 0
        GoTo weiter
      End If
      
      For i = 5 To 18 ' Spalten E bis R
            If Dneu <= Worksheets(ws2).Cells(n, i) Then
               Worksheets(ws2).Cells(n, i) = Worksheets(ws2).Cells(n, i) - Dneu
               Dneu = 0
            Else
               Dneu = Dneu - Worksheets(ws2).Cells(n, i)
               Worksheets(ws2).Cells(n, i) = 0
            End If
        Next i
        Worksheets(ws2).Cells(n, 4) = 0
weiter:
Next n



End Sub