Prozedur zu groß

[tomdaggi]

Hallo,

Dank eurer Hilfe habe ich diese Tabelle erstellt, leider ist diese so groß geworden (und wird noch größer) das ich eine Fehlermeldung erhalte.
In den Reiter Textil schreibe ich ein Datum und in dem Verlauf werden die entsprechenen Daten übertragen immer in die nächste frei Spalte.
Läuft super, jetzt erscheint nach weiteren Einträgen "Prozedur zu groß". Ich habe schon im Netz nach Lösungen gesucht, ich habe nichts gefunden
was mir hilft. Der "Call" Eintrag soll helfen aber wo und wie??
Kann der Fehler am Sub Worksheet_Change(ByVal Target As Range) liegen?
Meine VBA Kenntnisse sind nicht besonders gut, nur mit eurer Hilfe bin ich soweit gekommen.
Dankeschön im Voraus.

[Rabe]

Hi,

Kann der Fehler am Sub Worksheet_Change(ByVal Target As Range) liegen?
Meine VBA Kenntnisse sind nicht besonders gut, nur mit eurer Hilfe bin ich soweit gekommen.

leider kann nicht richtig getestet werden, da der Blattschutz passwortgeschützt ist.

[tomdaggi]

Sorry habe ich vergessen, test ist das Kennwort

[atilla]

Hallo,

da warst Du aber sehr fleißig. wahrscheinlich wolltest Du für die Konstellation True True noch mehr Code schreiben. Wenn ja, dann melde Dich noch einmal.

Ansonsten müsste Dein Code-"Roman" so zusammengekürzt werden können:

Code:

Sub Worksheet_Change(ByVal Target As Range)
    If Target.Row > 5 Then
      Select Case Target.Column
         Case 2
            If IsDate(Target.Text) Then
               If Year(Target) >= 2013 Then
                  If CheckBox1 = False And CheckBox2 = False Then
                     Worksheets("Verlauf 3Monate").Range("C10000").End(xlUp).Offset(1, 0) = Range("C3") & (" / ") & Range("A5") & (": ") & Cells(Target.Row, 1) & (" kann ") & Range("B3") & (" ") & Range("A3")
                     Worksheets("Verlauf 3Monate").Range("a10000").End(xlUp).Offset(1, 0) = Cells(Target.Row, 2)
                     Worksheets("Verlauf 3Monate").Range("b10000").End(xlUp).Offset(1, 0) = "1"
                  ElseIf CheckBox1 = True And CheckBox2 = False Then
                     Worksheets("Verlauf 1.Jahr").Range("C10000").End(xlUp).Offset(1, 0) = Range("C3") & (" / ") & Range("A5") & (": ") & Cells(Target.Row, 1)
                     Worksheets("Verlauf 1.Jahr").Range("a10000").End(xlUp).Offset(1, 0) = Cells(Target.Row, 2)
                     Worksheets("Verlauf 1.Jahr").Range("b10000").End(xlUp).Offset(1, 0) = "1"
                  End If
               End If
            End If
         Case 3
            If IsDate(Target.Text) Then
               If Year(Target) >= 2013 Then
                  If CheckBox1 = False And CheckBox2 = False Then
                     Worksheets("Verlauf 3Monate").Range("C10000").End(xlUp).Offset(1, 0) = Range("C3") & (" / ") & Range("A5") & (": ") & Cells(Target.Row, 1)
                     Worksheets("Verlauf 3Monate").Range("a10000").End(xlUp).Offset(1, 0) = Cells(Target.Row, 2)
                     Worksheets("Verlauf 3Monate").Range("b10000").End(xlUp).Offset(1, 0) = "1"
                  ElseIf CheckBox1 = True And CheckBox2 = False Then
                     Worksheets("Verlauf 1.Jahr").Range("C10000").End(xlUp).Offset(1, 0) = Range("C3") & (" / ") & Range("A5") & (": ") & Cells(Target.Row, 1)
                     Worksheets("Verlauf 1.Jahr").Range("a10000").End(xlUp).Offset(1, 0) = Cells(Target.Row, 3)
                     Worksheets("Verlauf 1.Jahr").Range("b10000").End(xlUp).Offset(1, 0) = "1"
                  End If
               End If
            End If
         Case 4
            If IsDate(Target.Text) Then
               If Year(Target) >= 2013 Then
                  If CheckBox1 = False And CheckBox2 = False Then
                     Worksheets("Verlauf 3Monate").Range("C10000").End(xlUp).Offset(1, 0) = Range("C3") & (" / ") & Range("A5") & (": ") & Cells(Target.Row, 1)
                     Worksheets("Verlauf 3Monate").Range("a10000").End(xlUp).Offset(1, 0) = Cells(Target.Row, 4)
                     Worksheets("Verlauf 3Monate").Range("b10000").End(xlUp).Offset(1, 0) = "1"
                  ElseIf CheckBox1 = True And CheckBox2 = False Then
                     Worksheets("Verlauf 1.Jahr").Range("C10000").End(xlUp).Offset(1, 0) = Range("C3") & (" / ") & Range("A5") & (": ") & Cells(Target.Row, 1)
                     Worksheets("Verlauf 1.Jahr").Range("a10000").End(xlUp).Offset(1, 0) = Cells(Target.Row, 4)
                     Worksheets("Verlauf 1.Jahr").Range("b10000").End(xlUp).Offset(1, 0) = "1"
                  End If
               End If
            End If
      End Select
   End If
End Sub

[atilla]

Hallo noch mal,

so wie ich sehe müsste sogar das reichen:

Code:

Sub Worksheet_Change(ByVal Target As Range)
    If Target.Row > 5 Then
      Select Case Target.Column
         Case 2, 3, 4
            If IsDate(Target.Text) Then
               If Year(Target) >= 2013 Then
                  If CheckBox1 = False And CheckBox2 = False Then
                     Worksheets("Verlauf 3Monate").Range("C10000").End(xlUp).Offset(1, 0) = Range("C3") & (" / ") & Range("A5") & (": ") & Cells(Target.Row, 1) & (" kann ") & Range("B3") & (" ") & Range("A3")
                     Worksheets("Verlauf 3Monate").Range("a10000").End(xlUp).Offset(1, 0) = Cells(Target.Row, Target.colum)
                     Worksheets("Verlauf 3Monate").Range("b10000").End(xlUp).Offset(1, 0) = "1"
                  ElseIf CheckBox1 = True And CheckBox2 = False Then
                     Worksheets("Verlauf 1.Jahr").Range("C10000").End(xlUp).Offset(1, 0) = Range("C3") & (" / ") & Range("A5") & (": ") & Cells(Target.Row, 1)
                     Worksheets("Verlauf 1.Jahr").Range("a10000").End(xlUp).Offset(1, 0) = Cells(Target.Row, Target.colum)
                     Worksheets("Verlauf 1.Jahr").Range("b10000").End(xlUp).Offset(1, 0) = "1"
                  End If
               End If
            End If
      End Select
   End If
End Sub

[Kuwer]

Hallo,

Da war ja 5 mal dasselbe drin.
Teste mal das:

Code:

Sub Worksheet_Change(ByVal Target As Range)
  If Not Application.Intersect(Target, Range("B6:D9")) Is Nothing Then
    If Target >= 2013 And CheckBox1 = False And CheckBox2 = False Then
      With Worksheets("Verlauf 3Monate").Cells(Rows.Count, 1).End(xlUp)
        .Offset(1, 0).Value = Target.Value
        .Offset(1, 1).Value = 1
        .Offset(1, 2).Value = Range("C3").Value & (" / ") & _
                              Range("A5").Value & (": ") & _
                              Range("A6").Value & (" kann ") & _
                              Range("B3").Value & (" ") & _
                              Range("A3").Value
      End With
    End If
  End If
  If Not Application.Intersect(Target, Range("B12:D15")) Is Nothing Then
    If Target >= 2013 And CheckBox1 = False And CheckBox2 = False Then
      With Worksheets("Verlauf 3Monate").Cells(Rows.Count, 1).End(xlUp)
        .Offset(1, 0).Value = Target.Value
        .Offset(1, 1).Value = 1
        .Offset(1, 2).Value = Range("C3").Value & (" / ") & _
                              Range("A11").Value & (": ") & _
                              Range("A12").Value & (" kann ") & _
                              Range("B3").Value & (" ") & _
                              Range("A3").Value
      End With
    End If
  End If
End Sub

Gruß Uwe

[Winny]

Hi

dann will ich doch auch meinen Senf dazugeben

Sub Worksheet_Change(ByVal Target As Range)

   Dim ws As Worksheet, lLastRow As Long

   

   If Not Intersect(Target, Union(Range("B6:D9"), Range("B12:D15"), Range("B18:D22"), Range("B25:D27"))) Is Nothing Then

      If Year(Target.Value) <= 2013 Then Exit Sub

      

      If CheckBox1 = False And CheckBox2 = False Then

         Set ws = Worksheets("Verlauf 3Monate")

      ElseIf CheckBox1 = True And CheckBox2 = False Then

         Set ws = Worksheets("Verlauf 1.Jahr")

      ElseIf CheckBox1 = True And CheckBox2 = True Then

         Set ws = Worksheets("Verlauf 2.Jahr")

      End If

      

      lLastRow = ws.Range("A10000").End(xlUp).Row + 1

      ws.Cells(lLastRow, 3).Value = _

          Range("C3") & (" / ") & Range("A5").Text & (": ") & Range("A6").Text & (" kann ") & Range("B3").Text & (" ") & Range("A3").Text

      ws.Cells(lLastRow, 1).Value = Target.Value

      ws.Cells(lLastRow, 2).Value = "1"

   End If

End Sub

[Castor]

Mal nur ein Hinweis, Leute;
eine Notation wie CheckBox1 = False And CheckBox2 = False ist nicht gerade professionell, da der Wert einer CheckBox ohnehin schon ein Boolescher ist. Da kann dann im erwünschten True-Fall das = True entfallen und im False-Fall schreibt man Not CheckBox1, im o.g. Fall also Not (CheckBox1 Or CheckBox2).
Gruß, Luc

[tomdaggi]

Wow, das geht aber schnell, wie saugt man sich so schnell den Code aus den Fingern?

Ja, Uwe du hast Recht, als ich die doppelten Einträge anpassen wollte ist mir die
Fehlermeldung aufgefallen.

Also erstmals herzlichen Dank an alle, ich bin begeistert.
Ich werde alle Beiträge Morgen erst testen können.
Bei weiteren Rückfragen möchte ich gerne auf eure Kompetenz zurückgreifen.

[BoskoBiati]

Hallo,

Für mich stellt sich das so dar:

Code:

Option Explicit

Sub Worksheet_Change(ByVal Target As Range)
Dim wks As Worksheet
Dim rng As Range
Dim loletzte As Long
If Target.Count > 1 Then Exit Sub
If Not Intersect(Target, Union(Range("B6:D9"), Range("B12:D15"))) Is Nothing Then Exit Sub
If Not IsDate(Target.Text) Or Year(Target) < 2013 Then Exit Sub
If Not checkbox1 And checkbox2 Then Exit Sub

If checkbox1 Then
    If checkbox2 Then
        Set wks = Worksheets("Verlauf 2. Jahr")
    Else
        Set wks = Worksheets("Verlauf 1. Jahr")
    End If
Else
    Set wks = Worksheets("Verlauf 3Monate")
End If

With wks
    loletzte = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    If Target.Row < 10 Then
        .Cells(loletzte, 3) = Range("C3") & " / " & Range("A5") & ":" & Cells(Target.Row, 1)
        If Not checkbox1 Then .Cells(loletzte, 3) = .Cells(loletzte, 3) & " kann " & B3 & " " & A3
    Else
        .Cells(loletzte, 3) = Range("C11") & " / " & Range("A11") & ":" & Cells(Target.Row, 1)
        If Target.Row = 12 Then .Cells(loletzte, 3) = .Cells(loletzte, 3) & " kann " & B3 & " " & A3
    End If
    .Cells(loletzte, 2) = 1
    .Cells(loletzte, 1) = Target
End With

End Sub