VBA Codes zusammenlegen

[mazor78]

Hallo nochmal,

jetzt habe ich das Problem das man bei den spalten F,G,H,I keine Uhrzeit mehr eingeben kann ! :s

Das liegt an dem Target UCase !

Gibt es eine Möglichkeit F,G,H,I auszuklinken ?

[snb]

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
   If Target.Count = 1 Then
         If Target.Row > 3 And Target.Column > 4 And Target.Column < 9 Then
           Application.EnableEvents = False
           If Not IsNumeric(Target) Then Target = UCase(Target)
           If Target.Column = 5 Then Target.Offset(, -1) = IIf(IsEmpty(Target), "", Date)
        End If
   End If
   Application.EnableEvents = True
End Sub

[mazor78]

Unsprungscode war dieser hier !

Bei diesem code kann ich keine Zeitwerte 00:00  in die Zellen F,G,H,I einfügen.




Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.EnableEvents = False
    If Not Intersect(Target, Range("E4:E1048576")) Is Nothing Then
       If Target.Count = 1 Then  'Bearbeiten mehrerer Zeilen wird abgefangen
           If Target = "" Then
               Target.Offset(0, -1) = ""
           Else
               Target.Offset(0, -1) = Now
           End If
       End If
    End If
    If Not Intersect(Target, Range("B4:J1048576")) Is Nothing Then
        If Target.Count = 1 Then  'Bearbeiten mehrerer Zeilen wird abgefangen
            If Not IsEmpty(Target) Then
                Target = UCase(Target)
            End If
        End If
    End If
    Application.EnableEvents = True
    On Error GoTo 0
End Sub

[atilla]

Hallo,

statt Spalten auszuschließen, kannst Du auch abfragen ob eine Zahl eingegeben wurde:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
   On Error Resume Next
   Application.EnableEvents = False
   If Not Intersect(Target, Range("E4:E1048576")) Is Nothing Then
      If Target.Count = 1 Then  'Bearbeiten mehrerer Zeilen wird abgefangen
          If Target = "" Then
              Target.Offset(0, -1) = ""
          Else
              Target.Offset(0, -1) = Now
          End If
      End If
   End If
   If Not Intersect(Target, Range("B4:J1048576")) Is Nothing Then
       If Target.Count = 1 Then  'Bearbeiten mehrerer Zeilen wird abgefangen
           If Not IsEmpty(Target) Then
               If Not IsNumeric(Target) Then Target = UCase(Target)
           End If
       End If
   End If
   Application.EnableEvents = True
   On Error GoTo 0
End Sub

oder Du benennst die Bereiche richtig:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
   On Error Resume Next
   Application.EnableEvents = False
   If Not Intersect(Target, Range("E4:E1048576")) Is Nothing Then
      If Target.Count = 1 Then  'Bearbeiten mehrerer Zeilen wird abgefangen
          If Target = "" Then
              Target.Offset(0, -1) = ""
          Else
              Target.Offset(0, -1) = Now
          End If
      End If
   End If
   If Not Intersect(Target, Union(Range("B4:E1048576"), Range("J4:J1048576"))) Is Nothing Then
       If Target.Count = 1 Then  'Bearbeiten mehrerer Zeilen wird abgefangen
           If Not IsEmpty(Target) Then
                Target = UCase(Target)
           End If
       End If
   End If
   Application.EnableEvents = True
   On Error GoTo 0
End Sub

trotzdem hier, wie man Spalten aus den benannten Bereichen ausschließen kann:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
   On Error Resume Next
   Application.EnableEvents = False
   If Not Intersect(Target, Range("E4:E1048576")) Is Nothing Then
      If Target.Count = 1 Then  'Bearbeiten mehrerer Zeilen wird abgefangen
          If Target = "" Then
              Target.Offset(0, -1) = ""
          Else
              Target.Offset(0, -1) = Now
          End If
      End If
   End If
   If Not Intersect(Target, Range("B4:J1048576")) Is Nothing Then
     Select Case Target.Column
       Case Is <> 6, 7, 8, 9
       If Target.Count = 1 Then  'Bearbeiten mehrerer Zeilen wird abgefangen
           If Not IsEmpty(Target) Then
               If Not IsNumeric(Target) Then Target = UCase(Target)
           End If
       End If
     End Select
   End If
   Application.EnableEvents = True
   On Error GoTo 0
End Sub

[snb]

@Att

Schon meinen Beitrag beobachtet ?

[atilla]

Hallo snb,

ja.

Aber dat will er nich.
Ich hatte vorher auch einen zusammengefassten Code gepostet, welchen er auch ignoriert.

[mazor78]

Ne Ne,

Ich habe gar nix ignoriert !

Ich habe es über If Not IsNumeric(Target) Then umgeschrieben





Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    Application.EnableEvents = False
    If Not Intersect(Target, Range("E4:E1048576")) Is Nothing Then
       If Target.Count = 1 Then  'Bearbeiten mehrerer Zeilen wird abgefangen
           If Target = "" Then
               Target.Offset(0, -1) = ""
           Else
               Target.Offset(0, -1) = Now
           End If
       End If
    End If
    If Not Intersect(Target, Range("B4:J1048576")) Is Nothing Then
        If Target.Count = 1 Then  'Bearbeiten mehrerer Zeilen wird abgefangen
            If Not IsNumeric(Target) Then
                Target = UCase(Target)
            End If
        End If
    End If
    Application.EnableEvents = True
    On Error GoTo 0
End Sub

[snb]

Du hast die einfachste Lösung ingnoriert:

http://www.clever-excel-forum.de/thread-...l#pid67755