Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
240to244
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
240to244
240to244
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Zeilen löschen?

Zeilen löschen?
10.04.2003 10:33:53
Dino
Hi Leute,

ich habe folgendes Ausgangspunkt (immer Splate A):

jetzt sollen alle Zeile gelöscht werden (auch die leeren) bis auf die Zeile die mit "File Full Name :" (die soll ersetzt werden) anfängt.

Das ganze soll hinter so aussehen (es sollen nur die Pfäde bleiben):

Wie mache ich das per VBA?

Vielen Dank vorab....

Gruß
Dino








4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: Zeilen löschen?
10.04.2003 12:14:37
L.Vira

Der Betreff ist nicht gerade genau gewählt. Lass folgenden Code
laufen:

''Vorausgesetzt, die Daten stehen in Spalte A
Option Explicit
Sub L_Vira()
Dim z As Long, lz As Long, S As Long, L As Long, P As String
lz = 65536
If [a65536] = "" Then lz = [a65536].End(xlUp).Row
Application.ScreenUpdating = False
For z = lz To 1 Step -1
If Not InStr(Cells(z, 1), ":c:\") > 0 Then
Rows(z).Delete
End If
Next
lz = [a65536].End(xlUp).Row
For z = 1 To lz
P = Cells(z, 1)
S = InStr(P, ":") + 1
L = Len(P) - S + 1
Cells(z, 1) = Mid(P, S, L)
Next
Application.ScreenUpdating = True
End Sub

Anzeige
Re: Zeilen löschen?
10.04.2003 12:36:06
Dino

Hi L.Vira,

super es funzt......

noch eine Frage:

ich möchte auch die Zeilen löschen die doppelte Pfäde haben.

z.B. wenn ich 4 mal dies: c:\zeichnungen\Details\Detc_neu.dgn
habe, dann soll es drei Mal gelöscht werden und es soll nur ein Pfad davon übrig bleiben.

Kann man das auch in Dein Makro einbinden???

Vielen vielen Dank

Gruß
Dino


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 Integer

Public 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

Anzeige
Re: Zeilen löschen?
10.04.2003 17:25:55
L.Vira

''Vorausgesetzt, die Daten stehen in Spalte A
Option Explicit
Sub L_Vira()
Dim z As Long, lz As Long, S As Long, L As Long, P As String
Rows(1).Insert
[a1] = "Pfade ohne Doppler"
[a1].Font.Bold = True
lz = 65536
If [a65536] = "" Then lz = [a65536].End(xlUp).Row
Application.ScreenUpdating = False
For z = lz To 2 Step -1
If Not InStr(Cells(z, 1), ":c:\") > 0 Then
Rows(z).Delete
End If
Next
lz = [a65536].End(xlUp).Row
For z = 2 To lz
P = Cells(z, 1)
S = InStr(P, ":") + 1
L = Len(P) - S + 1
Cells(z, 1) = Mid(P, S, L)
Next
[a:a].AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=[B:B], Unique:=True
Columns(1).Delete
Columns(1).AutoFit
Application.ScreenUpdating = True
End Sub

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige