Private Sub Worksheet_Change

Hallo VBA-Künstler,
Ich habe in meiner Excelmappe schon ein längeres
Private Sub Worksheet_Change(ByVal Target As Range)
auf dem ersten Tabellenblatt eingebaut.
Bisher habe ich es nur so hinbekommen, dass die direkte Spalte angesprochen wird, in der man gerade etwas einträgt.
Jetzt benötige ich noch eine Funktion dazu und bekomme das einfach nicht gebacken.
So sollte es sein:
Wenn in Spalte D ein '/ eingetragen ist, soll gar nichts passieren (Exit Sub)
Wenn in Spalte A, B, C, E, F, G, H, I, J eine nachträgliche Änderung vorgenommen wird sollen je nachdem, was in Spalte D steht, bestimmte Makros ausgelöst werden. Z.B.
Case "Einkauf"
Call Einkauf
Case "Fracht"
Call Fracht
Case "Kurier"
Call Kurier
Case "Andere"
Call Andere
Ich hoffe, Ihr könnt mir dabei weiterhelfen und freue mich schon auf Lösungsvorschläge.
Viele Grüße,
Larissa

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Column = 6 Then Select Case Target Case "EUR" Target.Offset(0, 1).NumberFormat = "#,##0.00 " Case "USD" Target.Offset(0, 1).NumberFormat = "#,##0.00 [$$-409]" End Select End If If Target.Column = 1 Or Target.Column = 2 Or Target.Column = 3 Or Target.Column = 5 Or _ Target.Column = 6 Or Target.Column = 7 Or Target.Column = 8 Or Target.Column = 9 Or Target.Column = 10 Then Select Case Cells(Target.Row, 4) Case "Einkauf" MsgBox "Call EK_" Case "Fracht" MsgBox "Call Fracht_" Case "Kurier" MsgBox "Call Kurier_" Case "Andere" MsgBox "Call Andere_" End Select End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim Bereich As Range With ActiveSheet.UsedRange Set Bereich = Intersect(Union(.Columns("A:C"), .Columns("E:J")), Target) End With If Not Bereich Is Nothing Then For Each Bereich In Bereich If Bereich.Row > 1 Then 'ohne überschrift Zeile 1 Select Case Cells(Bereich.Row, 4).Value Case "Einkauf": Call Einkauf Case "Fracht": Call Fracht Case "Kurier": Call Kurier Case "Andere": Call Andere End Select End If Next Bereich End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim Bereich As Range With ActiveSheet.UsedRange Set Bereich = Intersect(Union(.Columns("A:C"), .Columns("E:J")), Target) End With If Not Bereich Is Nothing Then For Each Bereich In Bereich.Columns(1) If Bereich.Row > 1 Then 'ohne überschrift Zeile 1 Select Case Cells(Bereich.Row, 4).Value Case "Einkauf": Call Einkauf Case "Fracht": Call Fracht Case "Kurier": Call Kurier Case "Andere": Call Andere End Select End If Next Bereich End If End Sub

Private Sub Worksheet_Change(ByVal Target As Range) Dim Bereich As Range, rTemp As Range Dim i As Integer, ii As Integer Dim booNot As Boolean With ActiveSheet.UsedRange Set Bereich = Intersect(Union(.Range("A:C"), .Range("E:J")), Target) End With If Not Bereich Is Nothing Then For i = 1 To Bereich.Areas.Count For Each rTemp In Bereich.Areas(i).Columns(1).Cells If i > 1 Then For ii = 1 To i - 1 booNot = (Not Intersect(Bereich.Areas(ii), rTemp.EntireRow) Is Nothing) If booNot Then Exit For Next ii End If If rTemp.Row > 1 And Not booNot Then 'ohne überschrift Zeile 1 Select Case Cells(rTemp.Row, 4).Value Case "Einkauf": Debug.Print "mach 1" Case "Fracht": Debug.Print "mach 2" Case "Kurier": Debug.Print "mach 3" Case "Andere": Debug.Print "mach 4" End Select End If booNot = False Next rTemp Next i End If End Sub

Hallo,
verstanden habe ich es immer noch nicht, :-(
wenn in Spalte 4 "/" steht kann ja nicht Einkauf oder Fracht drin stehen und somit
auch kein Makro aufgerufen werden.
Egal hier mal was zum testen,
habe die Msgbox in eine Funktion verfrachtet damit das Eventmakro schlanker bleibt.

Private Function MSG(rZelle As Range) As Long
If Not Cells(rZelle.Row, 4).Value = "/" Then
 If Application.WorksheetFunction.CountA(Cells(rZelle.Row, 4).EntireRow) > 0 Then
   MSG = MsgBox("Werden bereits erfasste Daten dieser Rechnung im Nachhinein geändert?", vbQuestion + vbYesNo, "Frage?")
 End If
End If
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Bereich As Range, rTemp As Range
Dim i As Integer, ii As Integer
Dim booNot As Boolean

With ActiveSheet.UsedRange
 Set Bereich = Intersect(Union(.Range("A:C"), .Range("E:J")), Target)
End With

 If Not Bereich Is Nothing Then
  For i = 1 To Bereich.Areas.Count
        
        For Each rTemp In Bereich.Areas(i).Columns(1).Cells
                
                If i > 1 Then
                  For ii = 1 To i - 1
                       booNot = (Not Intersect(Bereich.Areas(ii), rTemp.EntireRow) Is Nothing)
                       If booNot Then Exit For
                  Next ii
                End If
            
                If rTemp.Row > 1 And Not booNot Then  'ohne Überschrift Zeile 1 
                   If MSG(rTemp) = vbYes Then '<------------------- Funktion Msgbox 
                       Select Case Cells(rTemp.Row, 4).Value
                            Case "Einkauf": Debug.Print "mach 1"
                            Case "Fracht": Debug.Print "mach 2"
                            Case "Kurier": Debug.Print "mach 3"
                            Case "Andere": Debug.Print "mach 4"
                       End Select
                   End If
                End If
             
                booNot = False
        Next rTemp
   
   Next i
 End If

End Sub

Gruß Tino

Private Sub Worksheet_SelectionChange(ByVal Target As Range) If cells(ActiveCell.Row, 4) = "/" Then Exit Sub End If Dim Bereich As Range, rTemp As Range Dim i As Integer, ii As Integer Dim booNot As Boolean With ActiveSheet.UsedRange Set Bereich = Intersect(Union(.Range("A:C"), .Range("E:J")), Target) End With If IsEmpty(Bereich) Then Exit Sub Else If MsgBox("Sollen bereits erfasste Daten dieser Rechnung geändert werden?", vbQuestion + _ vbYesNo, "Frage?") = vbNo Then Exit Sub End If End If If Not Bereich Is Nothing Then For i = 1 To Bereich.Areas.Count For Each rTemp In Bereich.Areas(i).Columns(1).cells If i > 1 Then For ii = 1 To i - 1 booNot = (Not Intersect(Bereich.Areas(ii), rTemp.EntireRow) Is Nothing) If booNot Then Exit For Next ii End If If rTemp.Row > 1 And Not booNot Then 'ohne überschrift Zeile 1 Select Case cells(rTemp.Row, 4).Value Case "Einkauf": Call Einkauf_back Case "Fracht": Call Fracht_back Case "Kurier": Call Kurier_back Case "Andere": Call Andere_back End Select End If booNot = False Next rTemp Next i End If End Sub

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Private Sub Worksheet_Change

17 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

17
Beiträge zum Forumthread

Beiträge zu diesem Forumthread