Suche auch in Zellnamen

HAllo!
Habe da mal wieder ein Problemchen.
Ich möchte, dass mit auch die Zellnamen durchsucht und das Ergebnis angezeigt wird.
Hier mein Code (den ich dank eurer Hilfe habe):

Sub finden_HV()
' Startblatt merken, da hier nicht gesucht werden soll
Dim WshShell As Object
Application.ScreenUpdating = False
On Error Resume Next
'Sheets("Suchergebnis").Select
StartBlatt = ActiveSheet.Name
msuch = Range("x1") 'Application.InputBox("Bitte den Suchtext eingeben", , Range("c5"))
If msuch = "" Then GoTo Nachricht
Sheets("Suchergebnis").Visible = True
Sheets("Suchergebnis").Select
mblatt = ActiveSheet.Name
If msuch = False Then
Exit Sub
End If
Nachricht:
If Len(msuch) = 0 Then
MsgBox "Es muss schon ein Suchtext eingegeben werden"
Exit Sub
End If
Range("D1").Value = msuch
Range("A1:C1").ClearContents
Range("A3:G200").ClearContents
Range("A1").Select
Cells(1, 1).Value = "Gefundene Einträge für die Suche nach: " + msuch
Cells(1, 2).Value = "Fundstelle"
' alte vergebene Namen löschen
Z = 1
While Z  Sheets(i).Name Then
If Sheets(i).Visible Then
Worksheets(i).Select
button_true
If IsDate(msuch) Then
Set c = Cells.Find(DateValue(msuch), LookIn:=xlValues, lookat:=xlPart)
Else
If IsNumeric(msuch) Then
Set c = Cells.Find(Val(msuch), LookIn:=xlValues, lookat:=xlPart)
Else
Set c = Cells.Find(msuch, LookIn:=xlValues, lookat:=xlPart)
End If
End If
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Select
' Name für gefundene Zelle vergeben
ActiveWorkbook.Names.Add Name:="Suche" + Trim(Str(S)), RefersTo:="=" +  _
Selection.Address
'If c = "" Then Sheets(mblatt).Cells(Z, 1).Value = msuch
Sheets(mblatt).Cells(Z, 1).Value = c.Value
Sheets(mblatt).Cells(Z, 2).Value = Sheets(i).Name '+ "!" + C.Address
Sheets(mblatt).Cells(Z, 3).Value = ActiveCell.Offset(0, 1).Value
Sheets(mblatt).Cells(Z, 4).Value = ActiveCell.Offset(0, 2).Value
Sheets(mblatt).Cells(Z, 5).Value = ActiveCell.Offset(0, 4).Value
Sheets(mblatt).Cells(Z, 6).Value = ActiveCell.Offset(0, 6).Value
Sheets(mblatt).Cells(Z, 7).Value = Sheets(i).Name + "!" + c.Address
' Hyperlink eintragen in den Eintrag der gefundenen Stelle
Sheets(mblatt).Select
Cells(Z, 1).Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:=  _
_
"Suche" + Trim(Str(S)), TextToDisplay:=c.text
S = S + 1
Sheets(i).Select
Z = Z + 1
Set c = Cells.FindNext(c)
Loop While Not c Is Nothing And c.Address  firstAddress
End If
button_false
End If
End If
Next
Sheets(StartBlatt).Select
Suchergebnis.Show False
Sheets("Suchergebnis").Visible = False
End Sub

Gruß und Danke schon jetzt!
Werner

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

'Excel 2010 Sub aaaTest 'Namen auswerten und vergebene Namen löschen die mit "Suche" anfangen 'Sind auch Namen definiert, die keine Zellbereiche Sind, dann muss man _ noch eine Fehlerbehandlung einbauen. Dim objName As Name Dim lngZ As Long, rngC As Range lngZ = 3 '1. Zeile für Eintragen der Ergebnisse Dim wksErgebnis As Worksheet Set wksErgebnis = Worksheets("Suchergebnis") 'Tabelle in die Eingetragen werden soll For Each objName In ActiveWorkbook.Names With objName If .Visible = True Then wksErgebnis.Cells(lngZ, 1) = .Name Set rngC = .RefersToRange wksErgebnis.Cells(lngZ, 2) = rngC.Parent.Name 'Tabelle If rngC.Cells.Count > 1 Then wksErgebnis.Cells(lngZ, 3) = "mehrere Zellen" Else 'Zellwert des Namens wksErgebnis.Cells(Z, 3) = rngC.Value End If wksErgebnis.Cells(lngZ, 7) = "'" & .RefersTo 'bestimmte Namen löschen If Mid(.Name, 1, Len("Suche")) = "Suche" _ And InStr(.Name, wksErgebnis.Name) = 0 Then .Delete End If End If End With lngZ = lngZ + 1 Next objName End Sub

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Suche auch in Zellnamen

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread