4 Makros Zusammenfügen ??

[mellow]

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
With Target
    If .Column = 2 Then
        On Error Resume Next
        .Comment.Delete
        On Error GoTo 0
        If .Value = 2 Then
            With .AddComment
                .Text "Unterwegs " & CStr(Now)
                .Shape.TextFrame.AutoSize = True
            End With
         
        ElseIf .Value = 3 Then
            With .AddComment
                .Text "Erledigt" & CStr(Now)
                .Shape.TextFrame.AutoSize = True
            End With
        End If
    End If
End With
End Sub

Code:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngTMP As Range
    On Error GoTo Fin
    Application.EnableEvents = False
    ' Nur Spalte F und ab Zeile 8
    If Target.Column = 6 And Target.Row > 7 Then
        ' Wenn mehrere Zellen, dann...
        For Each rngTMP In Target
            If Trim(rngTMP.Value) <> "" Then
                rngTMP.Offset(, -4).Value = 0
                rngTMP.Offset(, -5).Value = "X"
            Else
                rngTMP.Offset(, -4).Value = ""
                rngTMP.Offset(, -5).Value = ""
            End If
        Next rngTMP
    End If
Fin:
    Application.EnableEvents = True
End Sub

Code:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim varTargetR, strB
' Makro startet nur, wenn in Spalte A was geändert wird
If Target.Column <> 1 Then Exit Sub
' Zeilennummer festhalten
varTargetR = Target.Row
' Wenn kein x drin ist, nix machen
If Cells(varTargetR, 1) = "x" Then
 
' Meldung Anfang ###-------------------------------------------------------------- ##
  ' Diese Meldung kannst löschen, wenn sie nervt
  If MsgBox("Dispo auflösen?", vbYesNo + vbQuestion, "Dispoplan") = vbNo Then
    Cells(varTargetR, 1) = ""
    Range("$A$" & varTargetR).Select
    Exit Sub
  End If
' Meldung Ende ###-------------------------------------------------------------- ##
 
  ' Bereich markieren und Formeln auflösen
  Range("$B$" & varTargetR & ":$I$" & varTargetR).Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
  Range("$A$" & varTargetR).Select
  Application.CutCopyMode = False
End If
End Sub

Code:

Sub MarkierteZeilenSortieren()
  With Selection
    If .Parent.ListObjects.Count Then
      .Parent.ListObjects(1).Unlist
    End If
    If .Columns.Count = .Parent.Columns.Count And .Rows.Count > 1 Then
      .Sort .Cells(1, 10), xlAscending, .Cells(1, 11), , xlAscending, , , xlNo
    End If
  End With
End Sub

Nabend,

da ich von VBA nicht wirklich Ahnung habe , brauche ich mal eure Hilfe :)

ich hab hier 4 Makros diese brauche ich alle für Tabelle1(Dispoplan)

kann man diese irgendwie zusammen fügen oder muß man den Makros das Tabellenblatt bennen?

Vielen Dank für eure Hilfe


Gruß mellow

[schauan]

Hallöchen,

das 4. Makro würde ich einzeln lassen. Die anderen 3 kannst Du in eins packen, wenn Du bei dem dritten wie bei den anderen beiden die Spalte mit = prüfst und weiter machst und nicht mit <> und das Sub verlässt. Reicht die Ahnung dazu ?

[mellow]

Hi,

Soviel Ahnung hab ich nicht davon  :20:

Gruss mellow

[ralf_b]

versuch mal damit. das 4. Makro hat nichts mit der Reaktion auf das Change Event zu tun. also ist es hier nicht mit drin. 

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngTMP As Range
     
Application.EnableEvents = False

With Target
    If .Column = 2 Then
        On Error Resume Next
        .Comment.Delete
        On Error GoTo 0
        If .Value = 2 Then
            With .AddComment
                .Text "Unterwegs " & CStr(Now)
                .Shape.TextFrame.AutoSize = True
            End With
         
        ElseIf .Value = 3 Then
            With .AddComment
                .Text "Erledigt" & CStr(Now)
                .Shape.TextFrame.AutoSize = True
            End With
        End If
       
    ElseIf .Column = 6 And .Row > 7 Then
     
        On Error GoTo Fin
       
        ' Nur Spalte F und ab Zeile 8
       
        ' Wenn mehrere Zellen, dann...
        If .CountLarge > 1 Then
            For Each rngTMP In Target
                If Trim(rngTMP.Value) <> "" Then
                    rngTMP.Offset(, -4).Value = 0
                    rngTMP.Offset(, -5).Value = "X"
                Else
                    rngTMP.Offset(, -4).Value = ""
                    rngTMP.Offset(, -5).Value = ""
                End If
            Next rngTMP
        End If
       
      ElseIf .Column = 1 Then  ' Makro startet nur, wenn in Spalte A was geändert wird
                       
            If Cells(.Row, 1) = "x" Then  ' Wenn kein x drin ist, nix machen
             
                ' Meldung Anfang ###-------------------------------------------------------------- ##
                  ' Diese Meldung kannst löschen, wenn sie nervt
                  If MsgBox("Dispo auflösen?", vbYesNo + vbQuestion, "Dispoplan") = vbNo Then
                    Cells(.Row, 1) = ""
                    Range("$A$" & .Row).Select
                    GoTo Fin
                  End If
                ' Meldung Ende ###-------------------------------------------------------------- ##
                 
                  ' Formeln auflösen
                  Range("$B$" & .Row & ":$I$" & .Row) = Range("$B$" & .Row & ":$I$" & .Row).Value
                  Range("$A$" & .Row).Select
                 
            End If
     
      End If
  End With

Fin:
    Application.EnableEvents = True

End Sub

[mellow]

Guten Morgen,

Makro 1 und 3 funktionieren...das 2. hat funktioniert irgendwie nicht :20:

hier ist der Original Code vom 2 makro...letzter Beitrag

https://www.clever-excel-forum.de/Thread...mel?page=2

Danke

Gruß Christian

[schauan]

Hallöchen,

da hat Ralf die ANforderung aus dem Kommentar noch mit verarbeitet ...

Code:

' Wenn mehrere Zellen, dann...
If .CountLarge > 1 Then
    For Each rngTMP In Target
'...
    Next rngTMP
End If

nimm aus dem codeteil die erste und letzte Zeile weg, also die über dem For ... und die nach dem Next ...

[mellow]

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngTMP As Range
     
Application.EnableEvents = False

With Target
    If .Column = 2 Then
        On Error Resume Next
        .Comment.Delete
        On Error GoTo 0
        If .Value = 2 Then
            With .AddComment
                .Text "Unterwegs " & CStr(Now)
                .Shape.TextFrame.AutoSize = True
            End With
         
        ElseIf .Value = 3 Then
            With .AddComment
                .Text "Erledigt" & CStr(Now)
                .Shape.TextFrame.AutoSize = True
            End With
        End If
       
    ElseIf .Column = 6 And .Row > 7 Then
     
        On Error GoTo Fin
       
        ' Nur Spalte F und ab Zeile 8
       
        ' Wenn mehrere Zellen, dann...
                   For Each rngTMP In Target
                If Trim(rngTMP.Value) <> "" Then
                    rngTMP.Offset(, -4).Value = 0
                    rngTMP.Offset(, -5).Value = "X"
                Else
                    rngTMP.Offset(, -4).Value = ""
                    rngTMP.Offset(, -5).Value = ""
                End If
            Next rngTMP
               
      ElseIf .Column = 1 Then  ' Makro startet nur, wenn in Spalte A was geändert wird
                       
            If Cells(.Row, 1) = "x" Then  ' Wenn kein x drin ist, nix machen
             
                ' Meldung Anfang ###-------------------------------------------------------------- ##
                  ' Diese Meldung kannst löschen, wenn sie nervt
                  If MsgBox("Dispo auflösen?", vbYesNo + vbQuestion, "Dispoplan") = vbNo Then
                    Cells(.Row, 1) = ""
                    Range("$A$" & .Row).Select
                    GoTo Fin
                  End If
                ' Meldung Ende ###-------------------------------------------------------------- ##
                 
                  ' Formeln auflösen
                  Range("$B$" & .Row & ":$I$" & .Row) = Range("$B$" & .Row & ":$I$" & .Row).Value
                  Range("$A$" & .Row).Select
                 
            End If
     
      End If
  End With

Fin:
    Application.EnableEvents = True

End Sub

Hab das mal rausgenommen. Aber trozdem kein Erfolg :20:

Und dann ist mir noch ein Fehler aufgefallen ,  wenn ich beim 1.Makro in die Zeile eine 2 oder 3 eingebe wird ja ein Kommentar eingefügt. Lösche ich die 2 oder 3 wieder kommt "Laufzeitfehler 13" kann man das so machen, das beim Löschen der Zahl auch der Kommentar gelöscht wird ?

Danke

Gruß Mellow

[schauan]

Hallöchen,

wenn man in der Tabelle2 in der Datei aus dem anderen Thread das Makro ersetzt durch den zuletzt geposteten code kann ich das beim Löschen einer Zelle nicht nachvollziehen. Löscht man mehrere Zellen einer Zeile, kommt der Fehler nicht, es passiert aber auch nix. Der Fehler 13 kommt erst, wenn man mehr als eine Zelle in Spalte B löscht.
Geht man anschliessend ins Debuggen und beendet das Makro, funktioniert darin nix mehr, weil die Eventreaktion am Anfang aufgehoben wurde.

---

Hallöchen,

das wäre mal für mehrere betroffene Zellen ...

Code:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)

Dim rngTMP As Range
Application.EnableEvents = False

With Target
  If Not Intersect(Target, Columns(2)) Is Nothing Then
    For Each rngTMP In Target
      With rngTMP
        If .Column = 2 Then
          On Error Resume Next
          .Comment.Delete
          On Error GoTo 0
          If .Value = 2 Then
            With .AddComment
              .Text "Unterwegs " & CStr(Now)
              .Shape.TextFrame.AutoSize = True
            End With
          ElseIf .Value = 3 Then
            With .AddComment
              .Text "Erledigt" & CStr(Now)
              .Shape.TextFrame.AutoSize = True
            End With
          End If
        End If
      End With
    Next rngTMP
  
  ElseIf Not Intersect(Target, Columns(6)) Is Nothing And _
    Target.Row + Target.Rows.Count - 1 > 7 Then
    On Error GoTo Fin
    ' Nur Spalte F und ab Zeile 8
      ' Wenn mehrere Zellen, dann...
      For Each rngTMP In Target
        With rngTMP
          If .Column = 6 And .Row > 7 Then
            If Trim(.Value) <> "" Then
              .Offset(, -4).Value = 0
              .Offset(, -5).Value = "X"
            Else
              .Offset(, -4).Value = ""
              .Offset(, -5).Value = ""
            End If
          End If
        End With
      Next rngTMP
    
  ElseIf Not Intersect(Target, Columns(1)) Is Nothing Then   ' Makro startet nur, wenn in Spalte A was geändert wird
    For Each rngTMP In Target
      With rngTMP
        ' Wenn kein x drin ist, nix machen
        If .Column = 1 And Cells(.Row, 1) = "x" Then
          ' Meldung Anfang ###-------------------------------------------------------------- ##
          ' Diese Meldung kannst löschen, wenn sie nervt
          If MsgBox("Dispo auflösen?", vbYesNo + vbQuestion, "Dispoplan") = vbNo Then
            Cells(.Row, 1) = ""
            Range("$A$" & .Row).Select
            GoTo Fin
          End If
          ' Meldung Ende ###-------------------------------------------------------------- ##
          ' Formeln auflösen
          Range("$B$" & .Row & ":$I$" & .Row) = Range("$B$" & .Row & ":$I$" & .Row).Value
          Range("$A$" & .Row).Select
        End If
      End With
    Next rngTMP
  End If
End With

Fin:
    Application.EnableEvents = True

End Sub

[mellow]

Super vielen Dank,

was ich jetzt nur noch ausprobieren muß , ob das Makro für das festsetzten der Zeilen funktioniert.

wird das x durch das 2. Makro gesetzt , kommt nicht die Msg Dipso auflösen.  Setzte ich das x manuell kommt die Msg

Aber das kann ich erst in ein paar Wochen testen.

Gruß mellow

[ralf_b]

wird das x durch das 2. Makro gesetzt , kommt nicht die Msg Dipso auflösen. 

weil da setzen des x im makro kein weiteres Event auslöst. Dann müsste die msg auch in diesen elseif zweig gesetzt werden. 

Setzte ich das x manuell kommt die Msg

       

weil dann das Event auf der richtigen Spalte auslöst. Das ist ein ganz neuer Makroaufruf und dann landet das Programm im richtigen Abfragezweig.

Ich dachte mir schon das es nicht dabei bleibt mal eben die drei Makros zusammen zu legen. Die Seiteneffekte machen sich erst später bemerkbar.