AW: Text in Textbox finden
27.05.2017 02:47:21
fcs
Hallo Marcel,
probiere es mal mit dem nachfolgen angepassten Makro.
Die Neunummerierung der Textboxen hab ich mal in ein separates Makro gepackt.
Gruß
Franz
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
'Variablen deklarieren
Dim Suchbegriff As String, Textfeldtext As String
Dim found As String
Dim i As Integer, ifound1st As Integer
Dim shp As Shape
Dim ws As Worksheet
'Bei einem Laufzeitfehler zur Fehlerbehandlung springen
On Error GoTo Fehler
'Hintergrundfarbe in Spalte entfernen
Columns(Target.Column).Interior.ColorIndex = xlNone
'Suchbegriff merken und gewaehlte Zelle mit gelb hinterlegen
With Target
Suchbegriff = .Value
.Interior.ColorIndex = 6
End With
Application.ScreenUpdating = False
found = "no"
For i = 2 To ActiveWorkbook.Worksheets.Count
Set ws = Worksheets(i)
With ws
.Select
'For Each-Schleife zum Ansprechen aller in dem Tabellenblatt eingesetzten Shapes
For Each shp In ws.Shapes
'prüfen ob Shape = Textbox
If shp.Type = msoTextBox Then
Textfeldtext = ""
With shp.Fill
'Bei dem Textfeld die Hintergrundfarbe zurücksetzen
.ForeColor.SchemeColor = 1
.Visible = msoTrue
'Den Text aus dem Textfeld auslesen und in Variable "Textfeldtext" schreiben
Textfeldtext = shp.TextFrame.Characters.Text
'Wenn der Suchbegriff in dem Textfeld vorkommt (hier über die Funktion "InStr" realisiert,
'ab dem ersten Buchstaben den Text mit dem Suchbegriff vergleicht)
If InStr(1, Textfeldtext, Suchbegriff, 1) Then
If found = "no" Then ifound1st = i
found = "yes"
'Hintergrundfarbe in rot ändern
.ForeColor.SchemeColor = 10
.Visible = msoTrue
shp.TopLeftCell.Select 'Zelle zum Shape selektieren
End If
End With
End If
Next shp
End With
Next i
If found = "no" Then
Cancel = True
Worksheets(1).Activate
MsgBox "Suchbegriff """ & Suchbegriff & """ nicht gefunden!"
Else
Worksheets(ifound1st).Select
Application.ScreenUpdating = True
With ActiveWindow
.ActiveCell.Show
End With
End If
Fehler:
With Err
Select Case .Number
Case 0 'alles ok
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Application.ScreenUpdating = True
End Sub
Sub Textboxen_neu_nummerieren()
'Textboxen neu nummerieren
Dim i As Integer, iCount as Integer
Dim ws As Worksheet, shp As Shape
Application.ScreenUpdating = False
For i = 2 To ActiveWorkbook.Worksheets.Count
Set ws = Worksheets(i)
With ws
iCount = 0
'Temporären Namen/Nummer ergeben
For Each shp In ws.Shapes
'prüfen ob Shape = Textbox
If shp.Type = msoTextBox Then
iCount = iCount + 1
shp.Name = "tempTextBox" & Format(iCount, "000")
End If
Next
'"temp" bei den Namen wieder entfernen
For Each shp In ws.Shapes
'prüfen ob Shape = Textbox
If shp.Type = msoTextBox Then
shp.Name = Mid(shp.Name, 5)
End If
Next
End With
Next
End Sub