PDA

Vollständige Version anzeigen : Suche nach Wortteil (z.B. max. 3 Buchstaben)


rapoport
16.03.2009, 13:35
Hallo nochmal, Hallo Nepumuk,

in einem Excel-2002-Arbeitsblatt benutze ich nun folgendes Makro, um in einem Sheet nach einem freien Suchbegriff zu suchen (Inhalt: Bezeichnungen sowie Abkürzungen von Bedienungsanleitungen) und diese dann zu listen.
Option Explicit


Public Sub Suche_Anzeige()
' © 062006 by Case
Dim rngBereich As Range
Dim strGefunden As String
Dim strFinden As String
Dim wksBlatt As Worksheet
Dim wksBlattNeu As Worksheet
Dim lngLetzteZeile As Long
Dim lngZeile As Long
Dim intSpalte As Integer

On Error GoTo Suche_Anzeige_Error

For Each wksBlatt In ThisWorkbook.Sheets
If wksBlatt.Name Like "Gefunden*" Then
Application.DisplayAlerts = False
wksBlatt.Delete
Application.DisplayAlerts = True
End If
Next wksBlatt

'Application.Run "RE_Fertigung.xls!Makro1"

strFinden = InputBox("Geben sie das gesuchte Wort oder" & vbLf & _
"den gesuchten Wortteil ein:", "Suchen", "D - ****")

Application.ScreenUpdating = False
'Application.StatusBar = "BITTE WARTEN .... BITTE WARTEN .... BITTE WARTEN .... BITTE WARTEN .... BITTE WARTEN .... BITTE WARTEN ...."

If strFinden = "" Then Exit Sub

Set wksBlattNeu = Worksheets.Add(before:=Sheets(1))
wksBlattNeu.Name = "Gefunden"

For Each wksBlatt In ThisWorkbook.Sheets
If wksBlatt.Name <> wksBlattNeu.Name Then
Set rngBereich = wksBlatt.Cells.Find(What:=strFinden, LookIn:=xlValues, lookat:=xlPart)
If Not rngBereich Is Nothing Then
strGefunden = rngBereich.Address
Do
lngZeile = rngBereich.Row
intSpalte = rngBereich.Column
lngLetzteZeile = lngLetzteZeile + 1
wksBlatt.Rows(lngZeile).Copy wksBlattNeu.Rows(lngLetzteZeile)
wksBlattNeu.Hyperlinks.Add Anchor:=wksBlattNeu.Cells(lngLetzteZeile, intSpalte), Address:="", SubAddress:= _
wksBlatt.Name & "!" & rngBereich.Address, TextToDisplay:=rngBereich.Value
wksBlattNeu.Cells(lngLetzteZeile, intSpalte).AddComment wksBlatt.Name & Chr(10) & rngBereich.Address & Chr(10)
Set rngBereich = wksBlatt.Cells.FindNext(rngBereich)
Loop While rngBereich.Address <> strGefunden
wksBlattNeu.Columns.AutoFit
End If
End If
Set rngBereich = Nothing
Next

'Application.Run "RE_Fertigung.xls!Makro11"

'Worksheets("Gefunden").Hyperlinks.Delete
'Worksheets("BA").Hyperlinks.Delete

Application.ScreenUpdating = True
'Application.StatusBar = "Suchergebnis"

Set wksBlattNeu = Nothing
On Error GoTo 0
Exit Sub

Suche_Anzeige_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set wksBlattNeu = Nothing
Set rngBereich = Nothing

End Sub


Nun haben die User das Problem, dass z.B. bei der Suche nach der Bezeichnung "TR" nicht nur die Treffer von der Anleitung "TR" sondern auch alle anderen Wörter, die diese Buchstabenfolge erhalten, gelistet werden.
Kann man das Makro irgendwie modifizieren, dass es z.B. nur Wörter mit maximal 3 Buchstaben durchsucht oder nur nach den ersten 3 Buchstaben beim Durchsuchen eines festgelegten Bereichs, z.b. A1:A100, "schaut"?

Ich hoffe das Problem ist soweit klar...
Besten Dank für jede Hilfe!

pefeu
16.03.2009, 15:33
Hallo Michael,

so könnte das aussehen:
<FONT FACE="Arial,FixedSys"Size=2>
<Blockquote>
<FONT COLOR=#0000FF>Option Explicit</FONT>

<FONT COLOR=#008000>'&nbsp;&nbsp;&nbsp;A1:A100</FONT>

<FONT COLOR=#0000FF>Public Sub</FONT>&nbsp;Suchen()

<FONT COLOR=#0000FF>Dim</FONT>&nbsp;rBereich&nbsp;&nbsp;<FONT COLOR=#0000FF>As</FONT>&nbsp;Range
<FONT COLOR=#0000FF>Dim</FONT>&nbsp;rZelle&nbsp;&nbsp;&nbsp;&nbsp;<FONT COLOR=#0000FF>As</FONT>&nbsp;Range

&nbsp;&nbsp;&nbsp;<FONT COLOR=#0000FF>Set</FONT>&nbsp;rBereich&nbsp;=&nbsp;Range("A1:A100")
&nbsp;&nbsp;&nbsp;<FONT COLOR=#0000FF>For Each</FONT>&nbsp;rZelle&nbsp;<FONT COLOR=#0000FF>In</FONT>&nbsp;rBereich
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<FONT COLOR=#0000FF>If</FONT>&nbsp;Left(UCase(rZelle.Value),&nbsp;2)&nbsp;=&nbsp;"TR"&nbsp;<FONT COLOR=#0000FF>Then</FONT>
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;MsgBox&nbsp;"Gefunden&nbsp;in&nbsp;"&nbsp;&amp;&nbsp;rZelle.Address
&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;<FONT COLOR=#0000FF>End If</FONT>
&nbsp;&nbsp;&nbsp;<FONT COLOR=#0000FF>Next</FONT>&nbsp;rZelle

<FONT COLOR=#0000FF>End Sub</FONT>&nbsp;

</Blockquote>
<FONT FACE="Courier New,FixedSys"Size=2>&nbsp;&nbsp;&nbsp;&nbsp;&nbsp;Code eingefügt mit <b><a href="http://rtsoftwaredevelopment.de" target="_blank">Syntaxhighlighter 4.4</a></b></FONT>
<FONT FACE="Arial,FixedSys"Size=2>
Du kannst eben nicht mehr mit der Find-Methode suchen.

Gruß Peter

rapoport
18.03.2009, 08:53
Hallo Peter,

Danke für Deinen Tipp.
Ich habe aber zwischenzeitlich die möglichen Suchbegriffe der User analysiert...; Den Code wie Du ihn vorgeschlagen hast, kann ich leider nicht bentuzen, weil z.B. die Suchbegriffe variieren können (weil nicht nur nach "TR" gesucht wird...)

Aber wenn ich das bereits vorhandene "Such-Makro" (Post #1) insoweit beschränken könnte, dass er nicht die komplette Arbeitsmappe, sondern nur einen festgelegten Bereich eines konkreten Excel-Sheets durchsuchen würde, wäre mir schon sehr geholfen.
Hättest Du da eine Idee?

Besten Dank...

rapoport
18.03.2009, 12:53
Hallo,

ich habe das Problem mit Hilfe des folgenden Codes lösen können...
Option Explicit

Public Sub Suche_Anzeige()
' © 062006 by Case

Dim rngBereich As Range
Dim strGefunden As String
Dim strFinden As String
Dim wksBlatt As Worksheet
Dim wksBlattNeu As Worksheet
Dim lngLetzteZeile As Long
Dim lngZeile As Long
Dim intSpalte As Integer

On Error GoTo Suche_Anzeige_Error

For Each wksBlatt In ThisWorkbook.Sheets
If wksBlatt.Name Like "Gefunden*" Then
Application.DisplayAlerts = False
wksBlatt.Delete
Application.DisplayAlerts = True
End If
Next wksBlatt

'''Formatierung

strFinden = InputBox("Geben sie das gesuchte Wort oder" & vbLf & _
"den gesuchten Wortteil ein:", "Suchen", "D - ****")

Application.ScreenUpdating = False
'Application.StatusBar = "BITTE WARTEN .... BITTE WARTEN .... BITTE WARTEN ...."

If strFinden = "" Then Exit Sub

Set wksBlattNeu = Worksheets.Add(before:=Sheets(1))
wksBlattNeu.Name = "Gefunden"

Set wksBlatt = ThisWorkbook.Worksheets("BA")
Set rngBereich = wksBlatt.Range("A6:A109").Find(What:=strFinden, LookIn:=xlValues, LookAt:=xlPart)
If Not rngBereich Is Nothing Then
strGefunden = rngBereich.Address
Do
lngZeile = rngBereich.Row
intSpalte = rngBereich.Column
lngLetzteZeile = lngLetzteZeile + 1
wksBlatt.Rows(lngZeile).Copy wksBlattNeu.Rows(lngLetzteZeile)
wksBlattNeu.Hyperlinks.Add Anchor:=wksBlattNeu.Cells(lngLetzteZeile, intSpalte), Address:="", SubAddress:= _
wksBlatt.Name & "!" & rngBereich.Address, TextToDisplay:=rngBereich.Value
wksBlattNeu.Cells(lngLetzteZeile, intSpalte).AddComment wksBlatt.Name & Chr(10) & rngBereich.Address & Chr(10)
Set rngBereich = wksBlatt.Range("A6:A109").FindNext(rngBereich)
Loop While rngBereich.Address <> strGefunden
wksBlattNeu.Columns.AutoFit
End If

Set rngBereich = Nothing

'''Formatierung

'Worksheets("Gefunden").Hyperlinks.Delete
'Worksheets("BA").Hyperlinks.Delete

Application.ScreenUpdating = True
'Application.StatusBar = "Suchergebnis"

Set wksBlattNeu = Nothing
On Error GoTo 0
Exit Sub

Suche_Anzeige_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Set wksBlattNeu = Nothing
Set rngBereich = Nothing

End Sub