Bezug löschen

Hai Excels,
ich lass mit untem stehenden Code Zeilen löschen.
Der code soll alle Zeilen löschen bei denen KEIN Zahlenwert drin steht (Spalte A)
das passt soweit.
Nun hab ich auch Tabellen die durch Formeln Ergebnisse erechnen jedoch sind die Bezugs Zeilen gelöscht worden (das passt). Diese Zeilen mit dem fehlenden Bezug möcht ich auch löschen.
Bsp.
in der ersten Zeile steht
1 Auto
in der zweiten lass ich einfach errechnen
4 Räder
wenn ich also 0 bei Auto hab löscht mir das makro die Zeile, die nächste verliert dadurch den Bezug......und mein makro löscht diese Zeile nicht!
Hier mein Code
For Each wsMy In Worksheets
If wsMy.Name Like "BL_*" Then
wsMy.Activate
lngZeile = 5
lngLetzte ~f~= Cells(65536, 1).End(xlUp).Row
If lngLetzte ~f~= lngZeile - 1 Then
wsMy.Delete
Else
Do Until lngZeile > lngLetzte
If Not (IsNumeric(Cells(lngZeile, 1).Value)) Or _
Cells(lngZeile, 1).Value ~f~= 0 Or Cells(lngZeile, 1).Value ~f~= "" Then
Range(lngZeile & ":" & lngZeile).Delete
lngLetzte ~f~= lngLetzte - 1
Else
lngZeile = lngZeile + 1
End If
Loop
End If
End If
Next
Vielen Dank für Eure Hilfe Gruss volker

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub tt() For Each wsMy In Worksheets If wsMy.Name Like "BL_*" Then With wsMy lngZeile = 5 lngLetzte = .Cells(65536, 1).End(xlUp).Row If lngLetzte = lngZeile - 1 Then .Delete Else For i = lngLetzte To lngZeile Step -1 If Not (IsNumeric(.Cells(i, 1).Value)) Or _ .Cells(i, 1).Value = 0 Or _ .Cells(i, 1).Value = "" Then .Rows(i).Delete End If Next i End With End If Next wsMy End Sub

Hai Rudi,
Danke für Deinen Code (den ich leider nicht eingefügt bekomm)
So hab ich es gemacht (dann bekomm ich den Fehler End With ohne With)


Sub Beschlaglistenauslesen()
Speicher = ActiveWorkbook.Name
Dim DName, Dateiname, Pfad
Dim DName2, Pfad2
Application.DisplayAlerts = False
Dim wsMy As Worksheet, lngZeile As Long, lngLetzte As Long
Application.ScreenUpdating = False
For Each wsMy In Worksheets
If wsMy.Name Like "BL_*" Then
wsMy.Activate
' automatisches ausfüllen Auftrags#; Kom.;Modell;Kunde;Termin;Sachbearbeiter
'Auftrags#
Range("AA5").Select
ActiveCell.FormulaR1C1 = "=IF((RC[-26])>0,R2C6,"""")"
Selection.AutoFill Destination:=Range("AA5:AA449"), Type:=xlFillCopy
'Kom.
Range("AB5").Select
ActiveCell.FormulaR1C1 = "=IF((RC[-27])>0,R2C4,"""")"
Selection.AutoFill Destination:=Range("AB5:AB449"), Type:=xlFillCopy
'Modell
Range("AC5").Select
ActiveCell.FormulaR1C1 = "=IF((RC[-28])>0,R1C3,"""")"
Selection.AutoFill Destination:=Range("AC5:AC449"), Type:=xlFillCopy
'Kunde
Range("AD5").Select
ActiveCell.FormulaR1C1 = "=IF((RC[-29])>0,R2C8,"""")"
Selection.AutoFill Destination:=Range("AD5:AD449"), Type:=xlFillCopy
'Termin
Range("AE5").Select
ActiveCell.FormulaR1C1 = "=IF((RC[-30])>0,R3C9,"""")"
Selection.AutoFill Destination:=Range("AE5:AE449"), Type:=xlFillCopy
'Saachbearbeiter
Range("AF5").Select
ActiveCell.FormulaR1C1 = "=IF((RC[-31])>0,R2C2,"""")"
Selection.AutoFill Destination:=Range("AF5:AF449"), Type:=xlFillCopy
With wsMy
lngZeile = 5
lngLetzte = .Cells(65536, 1).End(xlUp).Row
If lngLetzte = lngZeile - 1 Then
.Delete
Else
For i = lngLetzte To lngZeile Step -1
If Not (IsNumeric(.Cells(i, 1).Value)) Or _
.Cells(i, 1).Value = 0 Or _
.Cells(i, 1).Value = "" Then
.Rows(i).Delete
End If
Next i
End With
End If
Next wsMy
Application.ScreenUpdating = True
Worksheets("Holzliste").Activate
ActiveWorkbook.Save
Pfad = "\\Server04\av\Beschlagliste_Übergabe\Pulk"
DName = Speicher
Dateiname = Pfad & "\" & DName & ".xls"
ThisWorkbook.SaveAs Filename:=Dateiname
Pfad2 = "\\Server04\av\Zuschnitt Test"
DName = Speicher
Dateiname2 = Pfad2 & "\" & DName & ".xls"
ThisWorkbook.SaveCopyAs Filename:=Dateiname2
If Dir(Dateiname2, vbNormal)  "" Then bytmsg = MsgBox("Datei existiert! Überschreiben?",  _
vbYesNo)
If bytmsg = vbYes Then ThisWorkbook.SaveCopyAs Filename:=Dateiname2
' ActiveWorkbook.Close
Application.DisplayAlerts = True
'MsgBox "Fertig !"
End Sub

Vielen Dank Gruss volker

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread