Re: Zeilen löschen?
10.04.2003 13:41:12
Dan
Option Explicit
Public Const searched1 As String = "File"
Public Const searched2 As String = "Full"
Public rRowsToDelete As Range
Public rng As Range, rCell As Range
Public str As String
Public pos As IntegerPublic Sub DelRows()
Dim c
Set rng = Selection
For Each rCell In rng.Cells
'mit string "File Full" hat Find nicht richtig functioniert
'also war ich gezwungen die string in zwei Stucke zu trennen und einzeln suchen
Set c = rCell.Find(What:=searched1, _
LookIn:=xlValues, _
LookAt:=xlPart, _
MatchCase:=True)
If c Is Nothing Then '"File" nicht gefunden
Call UnionRowsToDelete(rCell)
Else
Set c = rCell.Find(What:=searched2, _
LookIn:=xlValues, _
LookAt:=xlPart, _
MatchCase:=True)
If c Is Nothing Then _
Call UnionRowsToDelete(rCell) '"Full" nicht gefunden
End If
Next rCell
If Not rRowsToDelete Is Nothing Then
rRowsToDelete.Delete
Set rRowsToDelete = Nothing
End If
Call PathOnly
Call NoRedundantPaths
Set rng = Nothing
End Sub
Private Sub UnionRowsToDelete(ByVal rDel As Range)
If rRowsToDelete Is Nothing Then
Set rRowsToDelete = rDel.EntireRow
Else
Set rRowsToDelete = Application.Union(rRowsToDelete, rDel.EntireRow)
End If
End Sub
Private Sub PathOnly()
For Each rCell In rng.Cells
If rCell.Value <> "" Then
str = CStr(rCell.Value)
pos = InStr(1, str, "\", vbTextCompare)
If pos > 0 Then _
rCell.Value = Right(str, Len(str) - (pos - 3))
End If
Next rCell
End Sub
Private Sub NoRedundantPaths()
Dim rCellTwo As Range
Dim strTwo As String
For Each rCell In rng.Cells
If rCell.Value <> "" Then
str = CStr(rCell.Value)
For Each rCellTwo In rng.Cells
If rCellTwo.Value <> "" And rCellTwo.Row <> rCell.Row Then
strTwo = CStr(rCellTwo.Value)
If str = strTwo Then
rCellTwo.Clear
Call UnionRowsToDelete(rCellTwo)
End If
End If
Next rCellTwo
End If
Next rCell
If Not rRowsToDelete Is Nothing Then
rRowsToDelete.Delete
Set rRowsToDelete = Nothing
End If
End Sub