Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.
Clever-Excel-Forum › Office-Anwendungen › Excel v
4 Makros Zusammenfügen ??

Thema geschlossen 
Baumstrukturmodus
4 Makros Zusammenfügen ??
mellow Offline
Benutzer
Registriert seit: 06.05.2019
Version(en): Professional Plus 2016
#1
19.12.2020, 18:55
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
Suchen
Antworten Top
schauan Offline
Einer von hier
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
#2
19.12.2020, 19:27
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 ? Smile
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Homepage Suchen
Antworten Top
mellow Offline
Benutzer
ThreadStarter

Registriert seit: 06.05.2019
Version(en): Professional Plus 2016
#3
19.12.2020, 22:22
Hi,

Soviel Ahnung hab ich nicht davon  :20:

Gruss mellow
Suchen
Antworten Top
ralf_b Offline
Benutzer
Registriert seit: 12.06.2020
Version(en): 2021
#4
20.12.2020, 00:52
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
Suchen
Antworten Top
mellow Offline
Benutzer
ThreadStarter

Registriert seit: 06.05.2019
Version(en): Professional Plus 2016
#5
20.12.2020, 06:23 (Dieser Beitrag wurde zuletzt bearbeitet: 20.12.2020, 06:23 von 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
Suchen
Antworten Top
schauan Offline
Einer von hier
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
#6
20.12.2020, 06:55
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 ...
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Homepage Suchen
Antworten Top
mellow Offline
Benutzer
ThreadStarter

Registriert seit: 06.05.2019
Version(en): Professional Plus 2016
#7
20.12.2020, 07:13
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
Suchen
Antworten Top
schauan Offline
Einer von hier
Registriert seit: 10.04.2014
Version(en): 97-2019 (32) + 365 (64)
#8
20.12.2020, 07:28 (Dieser Beitrag wurde zuletzt bearbeitet: 20.12.2020, 07:56 von 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
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Homepage Suchen
Antworten Top
mellow Offline
Benutzer
ThreadStarter

Registriert seit: 06.05.2019
Version(en): Professional Plus 2016
#9
20.12.2020, 10:57
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
Suchen
Antworten Top
ralf_b Offline
Benutzer
Registriert seit: 12.06.2020
Version(en): 2021
#10
20.12.2020, 15:08
(20.12.2020, 10:57)mellow schrieb: 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. 

Zitat: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.
Suchen
Antworten Top
Thema geschlossen 


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste