VBA Zellen leeren und Zeile löschen

[CHASiN1994]

Hey guys,

ich habe ein VBA Projekt und derzeit zwei Probleme auf der Zielgraden

anbei mein derzeitiger Code 

Code:

Sub Fehlzeiten_löschen()
Dim c As Range
   For Each c In ActiveSheet.UsedRange.Cells
   
       If InStr(LCase(c.Value), "#") <> 0 Then
       Range(c, c.Offset(0, 0)).ClearContents
       End If
       
       If InStr(LCase(c.Value), "fs") <> 0 Then
           Range(c, c.Offset(0, 1)).ClearContents
       End If
       
       If InStr(LCase(c.Value), "kr") <> 0 Then
       Range(c, c.Offset(0, 1)).ClearContents
       
       End If
       
       If InStr(LCase(c.Value), "ez") <> 0 Then
       Range(c, c.Offset(0, 1)).ClearContents
       
       End If
       
       If InStr(LCase(c.Value), "uf") <> 0 Then
       Range(c, c.Offset(0, 1)).ClearContents
       
       End If
       
       If InStr(LCase(c.Value), "ub") <> 0 Then
       Range(c, c.Offset(0, 1)).ClearContents
       
       End If
       
       If InStr(LCase(c.Value), "k1") <> 0 Then
       Range(c, c.Offset(0, 1)).ClearContents
End If




Next c

Dim Bereich As Range
Set Bereich = Union(Columns(4), Columns(6), Columns(8), Columns(10), Columns(12), Columns(14), Columns(16))
Bereich.Delete


 
End Sub

1. Mit dem ersten Teil möchte ich überall wenn "EZ", "FS"; "UB"; "UF"; etc. in den Zellen steht diese Zelle mit dem jeweiligen Inhalt und die Zelle rechts daneben leeren.
       - das klappt soweit ganz gut. das einzige was mich stört ist, dass teilweise in den Spalten B und C Namen (anonymisiert)  gelöscht werden. Dabei brauche ich Hilfe, dass es nicht mehr passiert

2. Mit dem zweiten Teil möchte ich, dass die Reihen wo in der Überschrift S1, S2, S3 etc. steht gelöscht werden. DAs funktioniert soweit.

3. Ich möchte einen dritten Teil hinzufügen, der anschließend alle Zeilen löscht wenn in Spalte D:J für diese Zeile keine Werte hat. Wenn in Spalte D, E, F entwas steht soll natürlich alles bleiben. Wenn ich Spalte D, E, F, G, H, I, J nichts steht, dann soll die Zeile einschließlich Namen gelöscht werden.

ich hoffe das war verstädnlich

[Mase]

Hi,

...dass teilweise in den Spalten B und C Namen (anonymisiert)  gelöscht werden...

Ist Dir klar warum?

a) Du durchläufst diese Zellen - Warum überhaupt?
b) Du suchst nach Zeichenketten und wenn gefunden, dann diese Zelleninhalte löschen und die daneben
    (Zwischenfrage: Was passiert bei Namen wie: "Alofs, Kranz, Huber")
c) Warum LCase() - Schau dir InStr() und dessen Möglichkeiten an (Stichwort: vbTextCompare)


Das sind Basics. Die lassen sich im Handbuch nachlesen.

[Gast 123]

Hallo

ich hoffe das war verstädnlich

Sollte ich die Aufgab richtig verstanden haben erkennt man es sofort am funktionierenden Code! Bitte zuerst die Originaldaten ins Beispiel kopieren und dort testen ob das Löschen der Leerzeilen ohne Stunden einwandfrei funktioniert!  Im Beispiel passiert nix an Originaldaten wenn das Makro noch einen Fehler hat. Viel Spass beim testen.

mfg  Gast 123

Code:

Option Explicit      '11.7.2019   Gast 123   für Clever Forum


'"EZ", "FS"; "UB"; "UF"; "KR"; "K1"  Löschen
'Leerzeilen ohne Stundenzahl mit löschen

Sub Fehlzeiten_löschen()
Dim AC As Range, lz1 As Long
Dim Bereich As Range, j As Long
  'LastZelle in Spalte A ermitteln
  lz1 = Cells(Rows.Count, 1).End(xlUp).Row
 
  'Schleife auf Spalte D-Q begrenzen!
  For Each AC In ActiveSheet.Range("D2:Q" & lz1)
      If InStr(LCase(AC.Value), "#") <> 0 Then
         AC.ClearContents
      ElseIf InStr(LCase(AC.Value), "fs") <> 0 Then
          AC.Offset(0, 1).ClearContents
      ElseIf InStr(LCase(AC.Value), "ez") <> 0 Then
         AC.Offset(0, 1).ClearContents
      ElseIf InStr(LCase(AC.Value), "uf") <> 0 Then
         AC.Offset(0, 1).ClearContents
      ElseIf InStr(LCase(AC.Value), "ub") <> 0 Then
         AC.Offset(0, 1).ClearContents
      ElseIf InStr(LCase(AC.Value), "kr") <> 0 Then
         AC.Offset(0, 1).ClearContents
      ElseIf InStr(LCase(AC.Value), "k1") <> 0 Then
         AC.Offset(0, 1).ClearContents
      End If
  Next AC

  Set Bereich = Union(Columns(4), Columns(6), Columns(8), Columns(10), Columns(12), Columns(14), Columns(16))
  Bereich.Delete

  'Schleife für -RÜCKWAERTS- löschen leerer Zellen
  'vorwaerts NICHT möglich, vraendert Zeilen Bezug!!
  For j = lz1 To 2 Step -1   'Rückwarts!!
     If WorksheetFunction.Sum(Cells(j, 4).Resize(1, 8)) = 0 Then
        Rows(j).Delete shift:=xlUp
     End If
  Next j

End Sub

[CHASiN1994]

Hallo


Sollte ich die Aufgab richtig verstanden haben erkennt man es sofort am funktionierenden Code! Bitte zuerst die Originaldaten ins Beispiel kopieren und dort testen ob das Löschen der Leerzeilen ohne Stunden einwandfrei funktioniert!  Im Beispiel passiert nix an Originaldaten wenn das Makro noch einen Fehler hat. Viel Spass beim testen.

mfg  Gast 123

Code:

Option Explicit      '11.7.2019   Gast 123   für Clever Forum


'"EZ", "FS"; "UB"; "UF"; "KR"; "K1"  Löschen
'Leerzeilen ohne Stundenzahl mit löschen

Sub Fehlzeiten_löschen()
Dim AC As Range, lz1 As Long
Dim Bereich As Range, j As Long
  'LastZelle in Spalte A ermitteln
  lz1 = Cells(Rows.Count, 1).End(xlUp).Row
 
  'Schleife auf Spalte D-Q begrenzen!
  For Each AC In ActiveSheet.Range("D2:Q" & lz1)
      If InStr(LCase(AC.Value), "#") <> 0 Then
         AC.ClearContents
      ElseIf InStr(LCase(AC.Value), "fs") <> 0 Then
          AC.Offset(0, 1).ClearContents
      ElseIf InStr(LCase(AC.Value), "ez") <> 0 Then
         AC.Offset(0, 1).ClearContents
      ElseIf InStr(LCase(AC.Value), "uf") <> 0 Then
         AC.Offset(0, 1).ClearContents
      ElseIf InStr(LCase(AC.Value), "ub") <> 0 Then
         AC.Offset(0, 1).ClearContents
      ElseIf InStr(LCase(AC.Value), "kr") <> 0 Then
         AC.Offset(0, 1).ClearContents
      ElseIf InStr(LCase(AC.Value), "k1") <> 0 Then
         AC.Offset(0, 1).ClearContents
      End If
  Next AC

  Set Bereich = Union(Columns(4), Columns(6), Columns(8), Columns(10), Columns(12), Columns(14), Columns(16))
  Bereich.Delete

  'Schleife für -RÜCKWAERTS- löschen leerer Zellen
  'vorwaerts NICHT möglich, vraendert Zeilen Bezug!!
  For j = lz1 To 2 Step -1   'Rückwarts!!
     If WorksheetFunction.Sum(Cells(j, 4).Resize(1, 8)) = 0 Then
        Rows(j).Delete shift:=xlUp
     End If
  Next j

End Sub

funktioniert super danke :)