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
572to576
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
572to576
572to576
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Frage an Josef Ehrensberger/Sepp?

Frage an Josef Ehrensberger/Sepp?
23.02.2005 17:23:33
Andrea
Hallo Sepp,
habe meine Frage zu deinem Super Makro unter Beitrag "Suchen und auflisten - Wulfgar" vom 19.2.05/ 13:22:21 angehängt.
Bitte um Rückmeldung.
Andrea

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Frage an Josef Ehrensberger/Sepp?
23.02.2005 17:38:14
Josef
Hallo Andrea!
Eine Möglichkeit!


      
Option Explicit
Sub MultiSeekAndDelete()
Dim rng As Range, rngU As Range
Dim sFirst As String
Dim sFind As String
Dim wks As Worksheet, neu As Worksheet
Dim lRow As Long
sFind = InputBox(
"Geben sie das gesuchte Wort oder" & vbLf & _
                  
"den gesuchten Wortteil ein:""Suchen""Suchbegriff")
                  
If sFind = "" Then Exit Sub
Set neu = Worksheets.Add(before:=Sheets(1))
neu.Name = 
"Suche_" & Format(Now, "dd.mm.yy_hhmmss")
   
For Each wks In ThisWorkbook.Sheets
   
      
If wks.Name <> neu.Name Then
      
      
Set rng = wks.Cells.Find(What:=sFind, LookIn:=xlValues, LookAt:=xlPart)
      
         
If Not rng Is Nothing Then
         sFirst = rng.Address
         
            
Do
            
            lRow = lRow + 1
            
            wks.Rows(rng.Row).Copy neu.Cells(lRow, 1)
            
   
'alle Zeilen mit dem gesuchten Begriff an eine Range-Variable übergeben
               If rngU Is Nothing Then
                  
Set rngU = wks.Rows(rng.Row)
               
Else
                  
Set rngU = Union(rngU, wks.Rows(rng.Row))
               
End If
            
            
Set rng = wks.Cells.FindNext(rng)
            
            
Loop While rng.Address <> sFirst
         
         
End If
      
      
End If
      
   
'Range mit Fundstellen löschen
   If Not rngU Is Nothing Then rngU.Delete
   
   
Set rngU = Nothing
   
Set rng = Nothing
   
   
Next
End Sub 
P.S.: Rückmeldung nicht vergessen!
Anzeige
AW: Frage an Josef Ehrensberger/Sepp?
Andrea
Wow,sehr gut,
besten Dank für umgehende AW, es funktioniert blendend. Meine Arbeit hat sich um gute Stunde verkurzt.
Andrea

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige