Live-Forum - Die aktuellen Beiträge
Datum
Titel
26.04.2024 09:08:00
Export alle Tabellenblätter als csv - in bestimmten Ordner
26.04.2024 08:56:40
Über alle Spalten nur €-Werte zählen
26.04.2024 08:08:24
Pivot Vormonatsveränderung
26.04.2024 07:54:11
nur den ersten Eintrag in spalte zählen
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1828to1832
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1828to1832
1828to1832
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

MsgBox mit if

MsgBox mit if
15.05.2021 11:07:00
oraculix
Hallo
Ich habe eine Suchabfrage mit einer MsgBox wenn nichts gefunden dann wird diese angezeigt.
und das Makro Wechselt aber trotzdem in eine andere Tabelle als ich gerne hätte.
Ich bräuchte sowas wie eine if abfrage zb. wenn kein Treffer dann in in Tabelle "FilmDb" aktivieren
ansonst
Tabelle "Gefunden" aktivieren
Weis leider nicht wie ich das in das Makro einbauen kann?
kann mir jemand helfen?
Danke
'In Tabelle FilmDB wird in Spalte A,B und H Gesucht Nach dem suchen wird in Tabelle "Gefunden" der gesuchte Eintrag gelistet.

Public Sub FilmDBFindenUndKopieren()
Worksheets("FilmDB").Activate
Dim iRowT As Long
Dim sWord As String, strFirstAddress As String
Dim objCell As Range
Dim objDictionary As Object
sWord = InputBox(Prompt:="Suchbegriff:", Default:="Filmname")
If sWord  vbNullString Then
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
iRowT = 3
With Worksheets("Gefunden")
Set objCell = Union(Columns("A:B"), Columns("H")).Find(What:=sWord, _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not objCell Is Nothing Then
strFirstAddress = objCell.Address
Do
If Not objDictionary.Exists(Key:=CStr(objCell.Row)) Then
objDictionary.Item(Key:=CStr(objCell.Row)) = vbNullString
objCell.EntireRow.Copy .Cells(iRowT, 1)
iRowT = iRowT + 1
End If
Set objCell = Union(Columns("A:B"), Columns("H")).FindNext(After:=objCell)
Loop Until objCell.Address = strFirstAddress
Set objCell = Nothing
Set objDictionary = Nothing
.Activate
.UsedRange.Font.Size = 14
With .Range("A2:J5000")
.Font.Color = RGB(255, 192, 0)
.Interior.Color = vbBlack
.Borders.Color = RGB(255, 192, 0)
End With
End If
End With
End If
Worksheets("Gefunden").Activate
Columns("A:A").ColumnWidth = 40.28
If iRowT > 3 Then
Worksheets("Gefunden").Activate
Columns("A:A").ColumnWidth = 40.28
Else
Call MsgBox("Nichts gefunden.", vbInformation, "Information")
End If
Application.ScreenUpdating = True
End Sub

17
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: MsgBox mit if
15.05.2021 11:09:12
Hajo_Zi 

If Not objCell Is Nothing Then
Worksheets("Gefunden").Activate
Columns("A:A").ColumnWidth = 40.28
If iRowT > 3 Then
Worksheets("Gefunden").Activate
Columns("A:A").ColumnWidth = 40.28
Else
Call MsgBox("Nichts gefunden.", vbInformation, "Information")
End If
Application.ScreenUpdating = True
endif
GrußformelHomepage
Anzeige
AW: MsgBox mit if
15.05.2021 11:34:35
oraculix
Danke
Leider Funktioniert Dein Code nicht
Habe If Not objCell Is Nothing Then eingefügt tut sich aber nichts bleibt alles beim alten
AW: MsgBox mit if
15.05.2021 13:11:35
Hajo_Zi
Zu Deiner Datei kann ich nichts schreiben, was wohl daran liegt das ich nicht auf fremde Rechner schaue.Ich baue keine Datei nach.
Sollte die Datei verlinkt werden?
Wenn du an Stelle einer Demomappe deine Originalmappe hochladen willst, diese aber sensible Daten enthält, kannst du diese Daten
http://www.ms-office-forum.de/forum/showthread.php?t=322895
ändern.
Bilder lade ich mir nicht runter, da Excel damit nichts anfangen kann.
http://www.excel-ist-sexy.de/bilder-statt-datei/
Hochgeladene Bilder können zwar als solche in Excel importiert werden, sind jedoch bei der Lösung von Problemen nicht sehr hilfreich, da man die eigentlichen Daten nicht ohne große und zeitraubende Umwege direkt in die Tabelle übertragen kann.
Das ist nur meine Meinung zu dem Thema.
http://www.excel-ist-sexy.de/bilder-statt-datei/
Hochgeladene Bilder können zwar als solche in Excel importiert werden, sind jedoch bei der Lösung von Problemen nicht sehr hilfreich, da man die eigentlichen Daten nicht ohne große und zeitraubende Umwege direkt in die Tabelle übertragen kann.
Das ist nur meine Meinung zu dem Thema.
Gruß Hajo
Anzeige
AW: MsgBox mit if
15.05.2021 12:22:19
GerdL
Moin, probier mal

Public Sub FilmDBFindenUndKopieren()
Dim iRowT As Long
Dim sWord As String, strFirstAddress As String
Dim objCell As Range
Dim objDictionary As Object
Worksheets("FilmDB").Activate
sWord = InputBox(Prompt:="Suchbegriff:", Default:="Filmname")
If sWord  vbNullString Then
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
iRowT = 3
Set objCell = Union(Columns("A:B"), Columns("H")).Find(What:=sWord, _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not objCell Is Nothing Then
strFirstAddress = objCell.Address
Do
If Not objDictionary.Exists(Key:=CStr(objCell.Row)) Then
objDictionary.Item(Key:=CStr(objCell.Row)) = vbNullString
objCell.EntireRow.Copy Worksheets("Gefunden").Cells(iRowT, 1)
iRowT = iRowT + 1
End If
Set objCell = Union(Columns("A:B"), Columns("H")).FindNext(After:=objCell)
Loop Until objCell.Address = strFirstAddress
Set objCell = Nothing
End If
Set objDictionary = Nothing
With Worksheets("Gefunden")
.UsedRange.Font.Size = 14
With .Range("A2:J5000")
.Font.Color = RGB(255, 192, 0)
.Interior.Color = vbBlack
.Borders.Color = RGB(255, 192, 0)
.Columns("A:A").ColumnWidth = 40.28
End With
End With
If iRowT > 3 Then
Worksheets("Gefunden").Activate
Else
Call MsgBox("Nichts gefunden.", vbInformation, "Information")
End If
End If
End Sub
Gruß Gerd
Anzeige
AW: MsgBox mit if
15.05.2021 12:35:53
oraculix
Juhuuu Super Danke Funktioniert.
Hätte noch ne frage falls du noch ein bisschen zeit hättest.
Kann man das so machen das die MsgBox nur 2 Sekunden erscheint ohne das ich immer auf Ok Klicken muss?
AW: MsgBox schließt automatisch
15.05.2021 13:00:59
GerdL
Aus dem www zusammengeklaubt. (Du musst das Makro mit "Call" aufrufen.)

Sub Popup()
Dim wshshell As Object
Dim strText As String
Set wshshell = CreateObject("WScript.Shell")
strText = wshshell.Popup("Nichts gefunden!", 2, "Suchergebnis:")
Set wshshell = Nothing
End Sub
Gruß Gerd
AW: MsgBox schließt automatisch
15.05.2021 13:29:42
oraculix
Danke für Deine Geduld mit einem Anfänger
Habe das Makro in Modul eingefügt.
Beim Aufruf Funktioniert es aber wenn ich es in den Code einfüge kommt MSGBOX und muss trotzdem OK klicken
hab ich es falsch eingefügt sieh mal

Public Sub AnsehenFindenUndKopieren2(Optional ByVal sWord As String)
Dim iRowT As Long
Dim strFirstAddress As String
Dim objCell As Range
Dim objDictionary As Object
Call GefundenDBLÖSCHEN
Worksheets("FilmeAnsehen").Activate
If sWord = vbNullString Then sWord = InputBox(Prompt:="Suchbegriff:", Default:="Filmname")
If sWord  vbNullString Then
Application.ScreenUpdating = False
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
iRowT = 3
With Worksheets("Gefunden")
Set objCell = Union(Columns("A:B"), Columns("H")).Find(What:=sWord, _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not objCell Is Nothing Then
strFirstAddress = objCell.Address
Do
If Not objDictionary.Exists(Key:=CStr(objCell.Row)) Then
objDictionary.Item(Key:=CStr(objCell.Row)) = vbNullString
objCell.EntireRow.Copy .Cells(iRowT, 1)
iRowT = iRowT + 1
End If
Set objCell = Union(Columns("A:B"), Columns("H")).FindNext(After:=objCell)
Loop Until objCell.Address = strFirstAddress
Set objCell = Nothing
Set objDictionary = Nothing
.Activate
.UsedRange.Font.Size = 14
With .Range("A2:J5000")
.Font.Color = RGB(255, 192, 0)
.Interior.Color = vbBlack
.Borders.Color = RGB(255, 192, 0)
End With
End If
End With
If iRowT > 3 Then
Worksheets("Gefunden").Activate
Columns("A:A").ColumnWidth = 40.28
Else
Call Popup("Nichts gefunden.", vbInformation, "Information")
End If
Application.ScreenUpdating = True
End If
End Sub

Anzeige
AW: MsgBox schließt automatisch
15.05.2021 14:04:31
GerdL
Nur "Call Popup" ohne Parameter.
AW: MsgBox schließt automatisch
15.05.2021 14:40:27
oraculix
Hab es als call im Makro platziert
Ergebniss:
Excel Hangt sich auf lässt sich nur mir str+alt entf stopen esc und arg+Pause ging nicht
AW: MsgBox schließt automatisch
15.05.2021 14:56:25
Nepumuk
Hallo,
teste mal:
Code:



[Cc]



Option Explicit

Private Declare PtrSafe Function MessageBoxTimeoutA Lib "user32.dll" ( _
        ByVal hWnd As LongPtr, _
        ByVal lpText As String, _
        ByVal lpCation As String, _
        ByVal uType As VbMsgBoxStyle, _
        ByVal wLanguageId As Integer, _
        ByVal dwMiliseconds As Long) As Long

Public Sub FilmDBFindenUndKopieren()

  Dim iRowT As Long
  Dim sWord As String, strFirstAddress As String
  Dim objCell As Range
  Dim objDictionary As Object

  Worksheets("FilmDB").Activate

  sWord = InputBox(Prompt:="Suchbegriff:", Default:="Filmname")

  If sWord <> vbNullString Then

     Set objDictionary = CreateObject(Class:="Scripting.Dictionary")

     iRowT = 3

     With Worksheets("Gefunden")

         Set objCell = Union(Columns("A:B"), Columns("H")).Find(What:=sWord, _
         LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)

         If Not objCell Is Nothing Then

            strFirstAddress = objCell.Address

            Do

               If Not objDictionary.Exists(Key:=CStr(objCell.Row)) Then

                  objDictionary.Item(Key:=CStr(objCell.Row)) = vbNullString

                  objCell.EntireRow.Copy .Cells(iRowT, 1)
                  iRowT = iRowT + 1

               End If

               Set objCell = Union(Columns("A:B"), Columns("H")).FindNext(After:=objCell)

            Loop Until objCell.Address = strFirstAddress

            Set objCell = Nothing
            Set objDictionary = Nothing

            .Activate

            .UsedRange.Font.Size = 14

            With .Range("A2:J5000")

                .Font.Color = RGB(255, 192, 0)
                .Interior.Color = vbBlack
                .Borders.Color = RGB(255, 192, 0)

            End With
         End If
     End With
  End If

  If iRowT > 3 Then

     Worksheets("Gefunden").Activate
     Columns("A:A").ColumnWidth = 40.28

  Else

     Call MessageBoxTimeoutA(Application.hWnd, "Nichts gefunden.", _
     "Information", vbInformation, 0, 2000)

  End If

  Application.ScreenUpdating = True

End Sub
Gruß
Nepumuk
Anzeige
AW: MsgBox schließt automatisch
15.05.2021 15:25:53
oraculix
Servus Nepumuk Danke
Da ist irgendwo ein Fehler ich seh ihn aber nicht.
Fehlermeldung:
Fehler beim Kompilieren:
Nach End Sub, End Function oder End Property können nur Kommentare stehen
AW: MsgBox schließt automatisch
15.05.2021 15:30:44
Nepumuk
Hallo,
das:

Private Declare PtrSafe Function MessageBoxTimeoutA Lib "user32.dll" ( _
ByVal hWnd As LongPtr, _
ByVal lpText As String, _
ByVal lpCation As String, _
ByVal uType As VbMsgBoxStyle, _
ByVal wLanguageId As Integer, _
ByVal dwMiliseconds As Long) As Long
muss direkt unter Option Explicit
Gruß
Nepumuk.
AW: MsgBox schließt automatisch
15.05.2021 15:27:01
GerdL
Hallo Nepumuk,
.Activate für Worksheets("Gefunden") ist m.E. einmal zuoft drin.
Gruß Gerd
Anzeige
AW: MsgBox schließt automatisch
15.05.2021 15:32:56
Nepumuk
Hallo Gerd,
das habe ich übersehen, bzw. nicht danach gesucht. Ich habe den Code aus seiner Mappe von vor einer Woche. Mir ging es um die MsgBox.
Gruß
Nepumuk
AW: MsgBox schließt automatisch
15.05.2021 15:42:30
oraculix
So habe jetzt Worksheets("FilmDB").Activate unten rausgenommen und es kommt immer der Feler
Fehler beim Kompilieren:
Nach End Sub , End Function oder End Property können nur Kommentare stehen

Public Sub FilmDBFindenUndKopieren()
Dim iRowT As Long
Dim sWord As String, strFirstAddress As String
Dim objCell As Range
Dim objDictionary As Object
Worksheets("FilmDB").Activate
sWord = InputBox(Prompt:="Suchbegriff:", Default:="Filmname")
If sWord  vbNullString Then
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
iRowT = 3
With Worksheets("Gefunden")
Set objCell = Union(Columns("A:B"), Columns("H")).Find(What:=sWord, _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
If Not objCell Is Nothing Then
strFirstAddress = objCell.Address
Do
If Not objDictionary.Exists(Key:=CStr(objCell.Row)) Then
objDictionary.Item(Key:=CStr(objCell.Row)) = vbNullString
objCell.EntireRow.Copy .Cells(iRowT, 1)
iRowT = iRowT + 1
End If
Set objCell = Union(Columns("A:B"), Columns("H")).FindNext(After:=objCell)
Loop Until objCell.Address = strFirstAddress
Set objCell = Nothing
Set objDictionary = Nothing
.Activate
.UsedRange.Font.Size = 14
With .Range("A2:J5000")
.Font.Color = RGB(255, 192, 0)
.Interior.Color = vbBlack
.Borders.Color = RGB(255, 192, 0)
End With
End If
End With
End If
If iRowT > 3 Then
'Worksheets("Gefunden").Activate
Columns("A:A").ColumnWidth = 40.28
Else
Call MessageBoxTimeoutA(Application.hWnd, "Nichts gefunden.", _
"Information", vbInformation, 0, 2000)
End If
Application.ScreenUpdating = True
End Sub

Anzeige
AW: MsgBox schließt automatisch
15.05.2021 15:54:32
Nepumuk
Hallo,
was ist daran so schwierig die Funktion an den Anfang des Moduls zu verschieben?
Hier nochmal deine Mappe: https://www.herber.de/bbs/user/146209.xlsm
Gruß
Nepumuk
AW: MsgBox schließt automatisch
15.05.2021 16:08:57
oraculix
Super jetzt Gehts Vielen Dank Euch beiden
Der Fehler war das ich
Private Declare PtrSafe Function MessageBoxTimeoutA Lib "user32.dll" ( _
nicht ganz oben im Modul Platziert habe

Links zu Excel-Dialogen

InputBox MessageBox

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige