Zeilennummer auslesen - ev. Link | HERBERS Excel Forum

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo, folgenden Code in ein Modul:
Option Base 1
Option Compare Text


Sub Suchen_und_anzeigen()
Dim Meldung         As Byte, Pos        As Byte
Dim Schleife        As Byte, y          As Byte
Dim Begriff, Suchen()                   As Variant
Dim Bereich                             As Range
Dim n%, x%, xZelle%, yZelle%
Dim xTabelle$(), Adresse$(), Text$
' Suchbegriff eingeben
Begriff = InputBox _
("Suchwort eingeben." & vbCrLf & _
"Willst Du Abbrechen,einfach Enter drücken", "S U C H M O D U S")
If Begriff = "" Then Exit Sub
Pos = InStr(Begriff, "+")
If Pos Then
ReDim Suchen(2)
Suchen(1) = Left(Begriff, Pos - 1)
Suchen(2) = Right(Begriff, Len(Begriff) - Pos)
Schleife = 2
Else
ReDim Suchen(1)
Suchen(1) = Begriff
Schleife = 1
End If
Application.ScreenUpdating = False
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
x = 1
For y = 1 To Schleife
For n = 1 To Sheets.Count
If Sheets(n).Name <> "Auswahltabelle" Then
' Letzte Zelle des Bereiches ermitteln. Diese Zelle wird als Startzelle für
' die Suche deffiniert, da Suche nach dieser Zelle, also in erster Zelle
' des Bereiches beginnt.
'Bereich festlegen
Set Bereich = Worksheets(n).UsedRange
With Worksheets(n).Range(Bereich.Address)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
With Sheets(n).Range(Bereich.Address)
Set c = .Find(Suchen(y), After:=Cells(yZelle, xZelle), LookIn:=xlValues)
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
ReDim Preserve Adresse(x): ReDim Preserve xTabelle(x)
xTabelle(x) = Sheets(n).Name
Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
Set c = .FindNext(c)
x = x + 1
Loop While Not c Is Nothing And c.Address <> ErsteAdresse
End If
End With
End If
Next n
Next y
Application.ScreenUpdating = True
' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner
' gefunden wurde dann ist x = 1
Select Case x
Case 1
Meldung = MsgBox("Es wurde leider Nix gefunden", _
vbOKOnly, "G E F U N D E N E   W E R T E")
Exit Sub
Case Else
Meldung = MsgBox("Hurra " & (x - 1) & " Übereinstimmungen gefunden.", _
vbOKOnly, "G E F U N D E N E   W E R T E")
'Tabelle einfügen
'ALTER CODE: Worksheets.Add.Move after:=Worksheets(Worksheets.Count)
On Error Resume Next
With ActiveSheet
.Name = "Startseite"
.[A1] = "Suchergebnis"
For n = 1 To x - 1
.Cells(n + 1, 1) = xTabelle(n)
.Cells(n + 1, 2) = Adresse(n)
Next n
End With
End Select
End Sub

Rückmeldung wäre nett !!!

>>> mfg Bugs <<<

Sicher ist, dass nichts sicher ist. Selbst das nicht.

Private Sub CommandButton1_Click() Dim wks As Worksheet Dim rng As Range Dim sAddress As String Dim sFind As Variant Dim cr As Long, tarWks As String tarWks = "Ergebnisse" cr = 65536 If Worksheets(tarWks).Cells(cr, 1) = "" Then cr = Worksheets(tarWks).Cells(cr, 1).End(xlUp).Row End If If cr < 2 Then cr = 2 sFind = InputBox("Suchbegriff") If sFind = "" Then Exit Sub For Each wks In Worksheets If wks.Name <> tarWks Then Set rng = wks.Range("A1:A10").Find(What:=sFind, _ lookat:=xlPart, LookIn:=xlValues) If Not rng Is Nothing Then sAddress = rng.Address Do Application.GoTo rng, True wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(cr) cr = cr + 1 Set rng = wks.Range("A1:A10").FindNext(After:=ActiveCell) If rng.Address = sAddress Then Exit Do Loop End If NextStart: End If Next wks MsgBox prompt:="Suche beendet!" End Sub

Hallo Matthias!
Also bei mir läuft es ohne Probleme!

Private Sub CommandButton1_Click()
Dim objSh As Worksheet, objTar As Worksheet
Dim rng As Range
Dim strFirst As String
Dim strFind As Variant
Dim lngRow As Long

On Error GoTo ErrExit

With Application
  .ScreenUpdating = False
  .EnableEvents = False
  .DisplayAlerts = False
  .Calculation = xlCalculationManual
  .Cursor = xlWait
End With

strFind = InputBox("Suchbegriff")
If strFind = "" Then GoTo ErrExit

Set objTar = Sheets("Ergebnisse")

lngRow = objTar.Cells(Rows.Count, 1).End(xlUp).Row

For Each objSh In Worksheets
  If Not objSh Is objTar Then
    strFirst = vbNullString
    Set rng = objSh.Range("A:E").Find(What:=strFind, _
      lookat:=xlPart, LookIn:=xlValues, after:=objSh.Range("E65536"))
    If Not rng Is Nothing Then
      strFirst = rng.Address
      Do
        lngRow = lngRow + 1
        If lngRow > Rows.Count Then
          MsgBox "Voll!"
          Exit Sub
        End If
        With objTar
          objSh.Range(objSh.Cells(rng.Row, 1), objSh.Cells(rng.Row, 31)).Copy .Rows(lngRow)
          .Hyperlinks.Add _
            Anchor:=.Cells(lngRow, 32), _
            Address:="", _
            SubAddress:="'" & objSh.Name & "'!" & rng.Address, _
            TextToDisplay:=objSh.Name & ", " & rng.Address(0, 0)
        End With
        Set rng = objSh.Range("A:E").FindNext(rng)
      Loop While Not rng Is Nothing And strFirst <> rng.Address
    End If
  End If
Next

MsgBox "Suche beendet!"

ErrExit:

Set objTar = Nothing
Set rng = Nothing

If Err.Number > 0 Then
  MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
  Err.Clear
End If

With Application
  .ScreenUpdating = True
  .EnableEvents = True
  .DisplayAlerts = True
  .Calculation = xlCalculationAutomatic
  .Cursor = xlDefault
End With

End Sub

Sollte es bei dir weiterhin nicht klappen, dann lade doch mal deine Mappe hoch.
Ich schau morgen wieder rein, gute Nacht.

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

Zeilennummer auslesen - ev. Link

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread