Office: (Office 2016) VBA Hilfe bei MSG Box

Hallo zusammen,
ich möchte per VBA eine Suche in Objekten starten was alles eigentlich auch wunderbar funktioniert.
Allerdings möchte ich die Boxen die angezeigt werden etwas umstellen und komm damit nicht wirklich klar.

Bei der Textsuche nach der Inputbox werden die Objekte durchsucht, wenn was gefunden wird, wird es angezeigt und man wird gefragt ob weitergesucht werden soll, soweit alles ok. Was ich gerne anders hätte. Wenn bei der ersten Abfrage oder beim weitersuchen nichts mehr gefunden wird, soll der Text mit einer abfrage eingebaut werden, "Kein Inhalt mit dem Text gefunden, anderen Text eingeben? Yes = Abfrage startet von neuem, No = EndSub. Ich hoffe ich konnte mich einigermaßen ausdrücken ;-)

Danke für die Unterstützung
Grüße MHS1002

HTML:

Option Explicit
Sub searchInForms()

  Dim objShp As Object
  Dim objWS As Worksheet
  Dim strSearch As String
  Dim retMsg As VbMsgBoxResult
  
  
  Set objWS = ThisWorkbook.ActiveSheet
  
  objWS.Unprotect Password:="XXX"
 
  strSearch = InputBox("Suchbegriff eingeben", "Textsuche")
  
  If Len(strSearch) Then
      For Each objShp In objWS.Shapes
        If InStr(1, objShp.TextFrame.Characters.Text, strSearch, vbTextCompare) Then
           
          
          Application.Goto Reference:=objShp.TopLeftCell, Scroll:=False
          
          'die Farbe des Text auf rot ändert.
          objShp.TextFrame.Characters.Font.Color = vbRed
          Application.ScreenUpdating = True
          retMsg = MsgBox("Weitersuchen?", vbYesNo, "Textsuche")
          
          'Farbe des Objekts wieder auf den Ursprungswert (weiss) setzen.
          objShp.TextFrame.Characters.Font.Color = vbWhite
          
          If retMsg = vbNo Then Exit For
          
        End If
      Next
      objWS.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="XXX"
      MsgBox "Suche beendet!", , "Textsuche"
      
      
      
  End If
 
 
  
End Sub

 

Hallo MHS1002,

Probier mal so:

Code:

...

NewMsg=vbYes
Erfolg=false

Do While NewMsg=vbYes
  strSearch = InputBox("Suchbegriff eingeben", "Textsuche")
  ...
          If InStr(1, objShp.TextFrame.Characters.Text, strSearch, vbTextCompare) Then
               Erfolg = true
...
      MsgBox "Suche beendet!", , "Textsuche" 
 End If

If Erfolg=true then
   NewMsg = MsgBox("Kein Inhalt mit dem Text gefunden, anderen Text eingeben?", vbYesNo, "Textsuche")
End if

Loop

...

Die Zeile

Code:

     objWS.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="XXX"

solltest Du ganz ans Ende setzen, damit Deine Datei am Ende auch wieter Passwortgeschützt ist.

Der Code ist ungetestet.

Gruß,
Lutz

 

Hallo Lutz,
vielen Dank für deine Hilfe...
Allerdings bekomme ich das nicht so zusammen, dass es läuft :-(
Könntest du mir den Code zusammensetzen, damit ich ihn testen kann?

Danke und Grüße

 

Hallo MHS1002,

anbei zusammengesetzt.
Es war tatsächlich auch ein Fehler in der neuen If-Abfrage drin.

Code:

Option Explicit
Sub searchInForms()

  Dim objShp As Object
  Dim objWS As Worksheet
  Dim strSearch As String
  Dim retMsg As VbMsgBoxResult
  
  
  Set objWS = ThisWorkbook.ActiveSheet
  
  objWS.Unprotect Password:="XXX"
 
NewMsg=vbYes
Erfolg=false

Do While NewMsg=vbYes

  strSearch = InputBox("Suchbegriff eingeben", "Textsuche")
  
  If Len(strSearch) Then
      For Each objShp In objWS.Shapes
        If InStr(1, objShp.TextFrame.Characters.Text, strSearch, vbTextCompare) Then
Erfolg = true
          
          Application.Goto Reference:=objShp.TopLeftCell, Scroll:=False
          
          'die Farbe des Text auf rot ändert.
          objShp.TextFrame.Characters.Font.Color = vbRed
          Application.ScreenUpdating = True
          retMsg = MsgBox("Weitersuchen?", vbYesNo, "Textsuche")
          
          'Farbe des Objekts wieder auf den Ursprungswert (weiss) setzen.
          objShp.TextFrame.Characters.Font.Color = vbWhite
          
          If retMsg = vbNo Then Exit For
          
        End If
      Next

      MsgBox "Suche beendet!", , "Textsuche"
      
      
      
  End If
 If Erfolg=false then
   NewMsg = MsgBox("Kein Inhalt mit dem Text gefunden, anderen Text eingeben?", vbYesNo, "Textsuche")
End if

Loop

       objWS.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="XXX"
  
End Sub

Gruß,
Lutz

 

Nochmals vielen dank.
Beim ausführen bekomme ich den Fehler: "Fehler beim Kompilieren, Variable nicht definiert.
Gleich zu Beginn bei:

HTML:

NewMsg = vbYes
Erfolg = False

 

Hi zusammen,
also das Makro hab ich nun zum laufen gebracht indem ich die Variablen definiert habe.
Allerdings hängt das Makro dann in einer Unendlichschleife und ich muss XL mit dem Taskmanager beenden.

Lutz oder sonst jemand evtl. noch ne Idee?

 

Hallo,

dabei ist vermutlich der (logische) Fehler nicht beseitigt worden - aber der Code wurde kompilierbar.

Du musst die Variable "NewMsg" mit einem Namen versehen, der zum nachfolgenden Code passt: "retMsg" - und diese eh deklariert;
Dieser falsche Variablenname kommt leider 3x vor - vermutlich ein Flüchtigkeitsfehler beim Zusammenstellen des Codes.

Die Variable "Erfolg" ist natürlich zuvor mit "Dim Erfolg As Boolean" zu deklarieren.

Code:

Option Explicit

Sub searchInForms()

  Dim objShp As Object
  Dim objWS As Worksheet
  Dim strSearch As String
  Dim retMsg As VbMsgBoxResult
  Dim Erfolg As Boolean
  
  Set objWS = ThisWorkbook.ActiveSheet
  
  objWS.Unprotect Password:="XXX"
 
  retMsg = vbYes
  Erfolg = False

  Do While retMsg = vbYes

     strSearch = InputBox("Suchbegriff eingeben", "Textsuche")
     
     If Len(strSearch) Then
         For Each objShp In objWS.Shapes
           If InStr(1, objShp.TextFrame.Characters.Text, strSearch, vbTextCompare) Then
             Erfolg = True
             
             Application.Goto Reference:=objShp.TopLeftCell, Scroll:=False
             
             'die Farbe des Text auf rot ändert.
             objShp.TextFrame.Characters.Font.Color = vbRed
             Application.ScreenUpdating = True
             retMsg = MsgBox("Weitersuchen?", vbYesNo, "Textsuche")
             
             'Farbe des Objekts wieder auf den Ursprungswert (weiss) setzen.
             objShp.TextFrame.Characters.Font.Color = vbWhite
             
             If retMsg = vbNo Then Exit For
             
           End If
         Next
         MsgBox "Suche beendet!", , "Textsuche"
     End If
     If Erfolg = False Then
        retMsg = MsgBox("Kein Inhalt mit dem Text gefunden, anderen Text eingeben?", vbYesNo, "Textsuche")
     End If

  Loop

  objWS.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="XXX"
  
End Sub

 

Hallo Anton,

vielen Dank für Deine Hilfe. Das Makro läuft nun etwas besser ab.
Wenn ich nun nach einem Text suche und bei der Abfrage weitersuchen auf nein klicke passt es, dann kommt die Box "Suche beendet"
Allerdings wenn ich auf weitersuchen klicke und nichts gefunden wurde kommt die Box Suche beendet. wenn ich das mit ok bestätige kommt wieder die Box weitersuchen? Hier sollte eigl. die Meldung ("Kein Inhalt mit dem Text gefunden, anderen Text eingeben?" kommen.
Wenn die Suche beendet ist, und mit ok bestätigt wird, soll das Makro zu Ende sein.

Vielleicht könnte da noch jemand Hand anlegen und helfen, danke!
Grüße

 

Hallo MHS1002,

ich habe den Code nochmal etwas modifiziert und so gut es ging getestet:

Code:

Option Explicit
Sub searchInForms()

  Dim objShp As Object
  Dim objWS As Worksheet
  Dim strSearch As String
  Dim retMsg As VbMsgBoxResult
  Dim NewMsg As VbMsgBoxResult

  
  Set objWS = ThisWorkbook.ActiveSheet
  
  objWS.Unprotect Password:="XXX"
 
NewMsg=vbYes


Do 

  strSearch = InputBox("Suchbegriff eingeben", "Textsuche")
  
  If Len(strSearch) Then
      For Each objShp In objWS.Shapes
        If InStr(1, objShp.TextFrame.Characters.Text, strSearch, vbTextCompare) Then
NewMsg=vbNo
          
          Application.Goto Reference:=objShp.TopLeftCell, Scroll:=False
          
          'die Farbe des Text auf rot ändert.
          objShp.TextFrame.Characters.Font.Color = vbRed
          Application.ScreenUpdating = True
          retMsg = MsgBox("Weitersuchen?", vbYesNo, "Textsuche")
          
          'Farbe des Objekts wieder auf den Ursprungswert (weiss) setzen.
          objShp.TextFrame.Characters.Font.Color = vbWhite
          
          If retMsg = vbNo Then Exit For
          
        End If
      Next
      
  End If
 If NewMsg=vbYes then
   NewMsg = MsgBox("Kein Inhalt mit dem Text gefunden, anderen Text eingeben?", vbYesNo, "Textsuche")
End if

Loop Until NewMsg=vbNo

      MsgBox "Suche beendet!", , "Textsuche"
       objWS.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True, Password:="XXX"
  
End Sub

Wozu hast Du eigentlich noch das
Application.ScreenUpdating = True
mitten im Code?

Gruß,
Lutz

 

Guten Morgen und herzlichen Dank.
Nun past es so, wie ich es mir vorgestellt hatte. Wirklich super und danke.

Wozu hier das Screenupdate eingeschaltet wird, weiss ich auch nicht mehr. Zumal es ja garnicht ausgeschaltet wird?!
Ich habs gleich raus genommen.

Viele Grüße