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
1276to1280
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
Inhaltsverzeichnis

Makro zum Suchen

Makro zum Suchen
marika
Hallo,
ich habe ein Makro gebaut, um nach bestimmten Texten zu suchen, wenn diese Texte gefunden wurden, soll die jeweilige Zeile ausgeschnitten werden und auf ein anderes Tabellenblatt eingefügt werden, die leeren Zeilen werden anschließend gelöscht. Das funktioniert auch ganz prima, mit jeweils einem Eintrag.
Wie mache ich, dass das Makro solange sucht bis er meinen Text nicht mehr findet und wenn es nichts mehr findet einfach aufhört.
Hab nicht viel VBA Ahnung und bin für jede Hilfe dankbar!
VG marika

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Makro zum Suchen
30.08.2012 22:36:25
{Boris}
Hi Marika,
wie wär`s, wenn Du uns mal Deinen bisherigen Code zeigst - am Besten direkt in einer Beispieldatei?
VG, Boris

AW: Makro zum Suchen
30.08.2012 22:49:10
marika
Hi Boris, mach ich gerne... die Datei ist hier https://www.herber.de/bbs/user/81656.xlsm
und das ist mein Code, falls er unterwegs verlorengegangen ist
Sub Makro1()
' Makro1 Makro
' Tastenkombination: Strg+l
Sheets("Tabelle1").Select
Range("A1").Select
Cells.Find(What:="lost", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.End(xlToLeft).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Sheets("lost").Select
Cells(1048576, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Tabelle1").Select
Selection.EntireRow.Delete
Range("A1").Select
Cells.Find(What:="in arbeit", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.End(xlToLeft).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Sheets("in arbeit").Select
Cells(1048576, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Tabelle1").Select
Selection.EntireRow.Delete
Range("A1").Select
Cells.Find(What:="vertrag", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
Selection.End(xlToLeft).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Cut
Sheets("vertrag").Select
Cells(1048576, 1).End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
Range("A1").Select
Sheets("Tabelle1").Select
Selection.EntireRow.Delete
Range("A1").Select
End Sub
VG marika

Anzeige
AW: Makro zum Suchen
30.08.2012 23:27:23
Josef

Hallo Marika,
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Const cstrStatus As String = "lost;in arbeit;vertrag" 'Suchbegriffe

Sub Makro1()
  '
  ' Makro1 Makro
  '
  ' Tastenkombination: Strg+l
  '
  Dim rng As Range, rngCopy As Range
  Dim objSh As Worksheet
  Dim vntSearch As Variant
  Dim strFirst As String
  Dim lngIndex As Long, lngNext As Long
  
  Dim lngCalc As Long
  
  On Error GoTo ErrExit
  
  With Application
    .ScreenUpdating = False
    .EnableEvents = False
    lngCalc = .Calculation
    .Calculation = -4135
    .DisplayAlerts = False
  End With
  
  vntSearch = Split(cstrStatus, ";")
  
  For lngIndex = 0 To UBound(vntSearch)
    Set rng = Nothing
    Set rngCopy = Nothing
    strFirst = ""
    
    If SheetExist(vntSearch(lngIndex)) Then
      Set objSh = Sheets(vntSearch(lngIndex))
    Else
      Set objSh = Worksheets.Add(After:=Sheets(Sheets.Count))
      objSh.Name = vntSearch(lngIndex)
      Sheets("Tabelle1").Range("A1:D1").Copy objSh.Range("A1")
    End If
    
    With objSh
      lngNext = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
    End With
    
    With Sheets("Tabelle1")
      Set rng = .Columns(4).Find(What:=vntSearch(lngIndex), LookAt:=xlWhole, LookIn:=xlValues, _
        MatchCase:=False, After:=.Cells(1, 4))
      If Not rng Is Nothing Then
        strFirst = rng.Address
        Do
          If rngCopy Is Nothing Then
            Set rngCopy = rng.EntireRow
          Else
            Set rngCopy = Union(rngCopy, rng.EntireRow)
          End If
          Set rng = .Columns(4).FindNext(rng)
        Loop While Not rng Is Nothing And strFirst <> rng.Address
      End If
    End With
    
    If Not rngCopy Is Nothing Then
      rngCopy.Copy objSh.Cells(lngNext, 1)
      rngCopy.Delete
    End If
    
  Next
  
  Sheets("Tabelle1").Activate
  
  ErrExit:
  
  With Err
    If .Number <> 0 Then
      MsgBox "Fehler in Prozedur:" & vbTab & "'Makro1'" & vbLf & String(60, "_") & _
        vbLf & vbLf & IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & _
        "Fehlernummer:" & vbTab & .Number & vbLf & vbLf & "Beschreibung:" & vbTab & _
        .Description & vbLf, vbExclamation + vbMsgBoxSetForeground, _
        "VBA - Fehler in Prozedur - Makro1"
      .Clear
    End If
  End With
  
  On Error GoTo 0
  
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = lngCalc
    .DisplayAlerts = True
    .StatusBar = False
  End With
  
  Set objSh = Nothing
  Set rngCopy = Nothing
  Set rng = Nothing
End Sub


Private Function SheetExist(ByVal sheetName As String, Optional Wb As Workbook) As Boolean
  Dim wks As Worksheet
  On Error GoTo ERRORHANDLER
  If Wb Is Nothing Then Set Wb = ThisWorkbook
  For Each wks In Wb.Worksheets
    If LCase(wks.Name) = LCase(sheetName) Then SheetExist = True: Exit Function
  Next
  ERRORHANDLER:
  SheetExist = False
End Function



« Gruß Sepp »

Anzeige
AW: Makro zum Suchen
31.08.2012 10:03:19
marika
Hi Sepp, 1000 Dank!! Ich habe heute versucht es auf meine "richtige Datei" anzuwenden und bekomme Fehler 13, Typen unverträglich. Die Zellen, von A1:S1 habe ich angepasst, auch die Spaltenanzahl, aber das schein noch nicht alles gewesen zu sein, leider verstehe ich sonst nur so ziemlich Bahnhof... ;(
Könntest du mir bitte nochmal weiterhelfen?
Hier habe ich die "richtige" Datei dazu https://www.herber.de/bbs/user/81659.xlsm
VG marika

AW: Makro zum Suchen
31.08.2012 12:45:34
Josef

Hallo Marika,
du hast alles richtig gemacht, nur bei .Find fehlt eine Anpassung.
After:=.Cells(1, 19)
dann läuft es

« Gruß Sepp »

Anzeige
AW: Makro zum Suchen
31.08.2012 13:33:04
marika
Hallo Sepp,
es (hatte) funktioniert, jetzt wollte ich die Eingabemöglichkeit in der Spalte, auf die 3 Werte festlegen und sobald ich eines der 3 Suchbegriffe irgendwo eintippe, bekomme ich die Fehlermeldung "Mehrdeutiger Name: SheetExist". Des Weiteren habe ich das Makro 3x angelegt, so dass es auf 2 weitere Tabellenblätter auch ausgeführt werden kann. Ich habe es ausprobiert und es ging auf allen Seiten, daher weiß ich jetzt nicht, womit er ein Problem hat, auch wenn ich die Regel zur Eingabe lösche, kommt die Fehlermeldung. Hast du 'ne Idee...?
Danke! und vg marika

AW: Makro zum Suchen
31.08.2012 13:37:46
Josef

Hallo Marika,
du brauchst den Code bestimmt nicht 3-Mal, wenn er immer auf der aktiven Tabelle ausgeführt werden soll, dann kann man das einfach einbauen.
Und die Funktion SheetExist() brauchst du natürlich auch nur einmal.
Wo das Problem mit der Gültigkeit liegt, kann ich von hier aus nicht beurteilen, hast du auch noch anderen Code in der Datei.
Lade doch deine aktuelle Datei hoch.

« Gruß Sepp »

Anzeige
AW: Makro zum Suchen
31.08.2012 14:25:05
marika
Hallol Sepp, ich weiß, dass man alles auch in einem Code steuern kann, aber da ich nicht weiß wie das geht, habe ich es einfach 3x kopiert ;)
Jetzt habe ich noch ein Makro drin, aber als die Fehlermeldung kam, war es aber noch nicht da. Habe die aktuelle Datei nochmal hochgeladen, wenn du nochmal schauen möchtest...

Die Datei https://www.herber.de/bbs/user/81661.xlsm wurde aus Datenschutzgründen gelöscht


vg marika

AW: Makro zum Suchen
31.08.2012 14:44:03
Josef

Hallo Marika,
ich kenne ja deine Anforderungen nicht, aber ich habe es jetzt so angelegt, das alle relevanten Tabellen durchsucht werden.
https://www.herber.de/bbs/user/81662.xlsm

« Gruß Sepp »

Anzeige
AW: Makro zum Suchen
31.08.2012 15:15:13
marika
Hallo Sepp,
ich wollte ja nicht so unverschämt sein und mir alles "bauen" lassen, ich dachte ein bisschen Hilfe bringt mich weiter... ;)) Ich danke dir viel-vielmals, jetzt ist es perfekt! :))
Wünsch dir ein schönes Wochenende.
vg marika

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige