Sub in private sub !?

[master2011]

Anbei mein Quellcode.

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rFind As Range
On Error GoTo Fehler
If InStr(Target.Address, ":") Then Exit Sub
If Target.Column <> 4 Then Exit Sub
 
If Target.Value <> Empty Then
    Set rFind = Columns(4).Find(what:=Target, After:=[d3], LookIn:=xlFormulas, _
        lookat:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
    If Not rFind Is Nothing Then
    If rFind.Address <> Target.Address Then
      rFind.Offset(0, -1) = rFind.Offset(0, -1) + 1
      Target.Select:  Target.Value = ""
      Exit Sub
    End If
    End If
End If
    If Target.Value = Empty Then
      Target.Offset(0, -1) = ""
      Target.Select
    ElseIf Target.Offset(0, -1) = "" Then
      Target.Offset(0, -1) = 1
      Target.Offset(1, 0).Select
    End If
   
    With ActiveSheet
      .PageSetup.PrintArea = Range(Range("AA1").Text).Address
      End With
     
Exit Sub
Fehler:  MsgBox "Position gelöscht"
End Sub


Es geht um den Fett markierten Teil, der meinen Dynamischen Druckbereich festlegen soll.
Wenn ich diesen Teil in ein Sub setze gehts einwandfrei, aber da ich ja bereits den privat sub habe müsste ich diesen hier integrieren.
Das wiederrum führt aber nicht zum gewünschten Ergebnis.

Kann mir da jemand helfen? 

[Der Steuerfuzzi]

Hallo,

Wenn ich diesen Teil in ein Sub setze gehts einwandfrei, aber da ich ja bereits den privat sub habe müsste ich diesen hier integrieren.
Das wiederrum führt aber nicht zum gewünschten Ergebnis.

Wie äußert sich denn das Problem genau? Gibt es eine Fehlermeldung? Wenn ja, welche und in welcher Zeile?

Dein Code sollte in beiden Subs korrekt funktionieren. Activesheet ist übrigens das aktive Tabellenblatt, also das, in dem die Änderung stattfindet.

[EA1950]

Hallo,

du musst natürlich dafür sorgen, dass die Programmausführung auch dorthin gelangen kann.
Wenn du diese mit "Exit Sub" frühzeitig verlässt, kann der Druckbereich nicht mehr festgelegt werden.
Ich habe statt dessen 3 unschöne Sprungbefehle eingebaut - aber sie sollten zumindest funktionieren.

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim rFind As Range
   On Error GoTo Fehler
   If InStr(Target.Address, ":") Then Goto PrintArea_festlegen
   If Target.Column <> 4 Then Goto PrintArea_festlegen
   
   If Target.Value <> Empty Then
       Set rFind = Columns(4).Find(what:=Target, After:=[d3], LookIn:=xlFormulas, _
           lookat:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
       If Not rFind Is Nothing Then
         If rFind.Address <> Target.Address Then
           rFind.Offset(0, -1) = rFind.Offset(0, -1) + 1
           Target.Select:  Target.Value = ""
           GoTo PrintArea_festlegen
         End If
       End If
   End If
   If Target.Value = Empty Then
      Target.Offset(0, -1) = ""
      Target.Select
   ElseIf Target.Offset(0, -1) = "" Then
      Target.Offset(0, -1) = 1
      Target.Offset(1, 0).Select
   End If
  
PrintArea_festlegen:
   With ActiveSheet
      .PageSetup.PrintArea = Range(Range("AA1").Text).Address
   End With
       
   Exit Sub
Fehler:
   MsgBox "Position gelöscht"
End Sub

Und hoffentlich ist dir der Verwendungszweck der Callback-Routine für das Change-Event des Arbeitsblattes auch wirklich klar.

[master2011]

Hallo,

Wie äußert sich denn das Problem genau? Gibt es eine Fehlermeldung? Wenn ja, welche und in welcher Zeile?

Dein Code sollte in beiden Subs korrekt funktionieren. Activesheet ist übrigens das aktive Tabellenblatt, also das, in dem die Änderung stattfindet.

Das Problem äußert sich mir gegenüber leider nur mit Arbeitsverweigerrung.

Also kein Fehler, aber leider auch keine Funktion.

Activesheet ist so richtig, da die ich auf einem anderen Arbeitsblatt eine andere Funktion nutze.

[Der Steuerfuzzi]

Dein code wird wahrscheinlich nicht abgearbeitet.

Kleiner Tip: Gehe mal im Einzelschrittmodus durch das Makro und prüfe es Zeile für Zeile, ob es das macht, was es soll.
Noch ein Tip: Wirf Deine Suchmaschine an und suche mal, was Empty bedeutet bzw. wie man auf leere Zellen prüft.
Letzter Tip: Es gibt neben If und Then auch noch Else. Dein zweites If könnte man auch alse Else-Zweig schreiben. Les da nochmal nach.
Allerletzter Tip: GoTo macht Code schlecht lesbar und wird häufig als schlechter Stil gesehen. In 99% der Fälle braucht man kein GoTo

[master2011]

Hallo,

du musst natürlich dafür sorgen, dass die Programmausführung auch dorthin gelangen kann.
Wenn du diese mit "Exit Sub" frühzeitig verlässt, kann der Druckbereich nicht mehr festgelegt werden.
Ich habe statt dessen 3 unschöne Sprungbefehle eingebaut - aber sie sollten zumindest funktionieren.

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
   Dim rFind As Range
   On Error GoTo Fehler
   If InStr(Target.Address, ":") Then Goto PrintArea_festlegen
   If Target.Column <> 4 Then Goto PrintArea_festlegen
   
   If Target.Value <> Empty Then
       Set rFind = Columns(4).Find(what:=Target, After:=[d3], LookIn:=xlFormulas, _
           lookat:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
       If Not rFind Is Nothing Then
         If rFind.Address <> Target.Address Then
           rFind.Offset(0, -1) = rFind.Offset(0, -1) + 1
           Target.Select:  Target.Value = ""
           GoTo PrintArea_festlegen
         End If
       End If
   End If
   If Target.Value = Empty Then
      Target.Offset(0, -1) = ""
      Target.Select
   ElseIf Target.Offset(0, -1) = "" Then
      Target.Offset(0, -1) = 1
      Target.Offset(1, 0).Select
   End If
  
PrintArea_festlegen:
   With ActiveSheet
      .PageSetup.PrintArea = Range(Range("AA1").Text).Address
   End With
       
   Exit Sub
Fehler:
   MsgBox "Position gelöscht"
End Sub

Und hoffentlich ist dir der Verwendungszweck der Callback-Routine für das Change-Event des Arbeitsblattes auch wirklich klar.

Leider funktioniert das auch nicht.
Der Druckbereich wird zwar gesetzt, aber verschiebt sich auch nicht nach unten, sobald ich eine neue zeile beschreibe.

Ich muss gestehen das ich VBA Neuling bin und mir einen Großteil der Codes selbst zusammengebaut habe oder von anderer Seite Hilfe bekommen habe.
Was die Callback-Routine ist !? Kein Plan ?

---

Dein code wird wahrscheinlich nicht abgearbeitet.

Kleiner Tip: Gehe mal im Einzelschrittmodus durch das Makro und prüfe es Zeile für Zeile, ob es das macht, was es soll.
Noch ein Tip: Wirf Deine Suchmaschine an und suche mal, was Empty bedeutet bzw. wie man auf leere Zellen prüft.
Letzter Tip: Es gibt neben If und Then auch noch Else. Dein zweites If könnte man auch alse Else-Zweig schreiben. Les da nochmal nach.

Ich versuche das mal in meinem nichtvorhanden Wissen zu verarbeiten.

Ich denke, dass diese Fallback Routine dafür sorgt, immer und immerwieder die Schleife durchzulaufen.
Somit komme ich erst garnicht zu dem Punkt, dass er mir den Druckbereich dynamisch erweitern könnte , oder?

Aber leider hat das mit den 3 Schleifen ja auch nicht geklappt

[Der Steuerfuzzi]

Ich habe meinen Beitrag nochmal editiert. Bitte lies ihn nochmal durch.

[Kuwer]

Hallo,

teste es mal so:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim rFind As Range

  ' If InStr(Target.Address, ":") Then Exit Sub
  If Target.Cells.Count = 1 Then
     ' If Target.Column <> 4 Then Exit Sub
     If Target.Column = 4 Then
        On Error GoTo Fehler
        Application.EnableEvents = False
        ' If Target.Value <> Empty Then
        If Len(Target.Value) Then
           Set rFind = Columns(4).Find(what:=Target.Value, LookIn:=xlFormulas, _
           lookat:=xlWhole, SearchDirection:=xlNext, MatchCase:=False)
           If Not rFind Is Nothing Then
              If rFind.Address <> Target.Address Then
                 rFind.Offset(0, -1).Value = rFind.Offset(0, -1).Value + 1
                 Target.Select:  Target.Value = ""
                 ' Exit Sub
              End If
           End If
        ElseIf Target.Value = "" Then
           Target.Offset(0, -1) = ""
           Target.Select
        ElseIf Target.Offset(0, -1).Value = "" Then
           Target.Offset(0, -1).Value = 1
           Target.Offset(1, 0).Select
        End If
        Me.PageSetup.PrintArea = Range("AA1").Text
        Application.EnableEvents = True
        On Error GoTo 0
     End If
  End If
  Exit Sub
Fehler:
  Application.EnableEvents = True
  On Error GoTo 0
  MsgBox "Position gelöscht"
End Sub

---

'  VBA, XML, HTML => Forum-HTML, © 2018 by KHV (VBA) und Haklesoft (VB)

Gruß Uwe