Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
308to312
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
308to312
308to312
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

erneute abfrage bis button nein

erneute abfrage bis button nein
11.09.2003 18:28:21
hubert
Hallo leute habe folgenden code " geklaut aud dem Forum "

möchte aber nach "s = InputBox("bitte das gesuchte Kennzeichen eingeben:", "Fahrzeug suchen und kopieren")
If s = "" Then
MsgBox "Es wurde kein Suchbegriff eingegeben !", vbExclamation, _
"Hinweis für " & Application.UserName & ":""

nicht abbrechen sondern solange suchen bis ich nein anklicke

wie bekomme ich da hin wie muß ich wo was ändern??

vielen dank für eure hilfe

mfg

hubert



Sub SuchenUndKopierenundlöschen()
Dim SuBe As Range
Dim s As String, za1 As String, za2 As String, za3 As String, za4 As String
Dim I As Long, fiR As Long, laRq As Long, laRz As Long
Dim laC As Integer
Dim gef As Boolean
Const bartikel As String = "artikel"
Const barchiv As String = "archiv"
s = InputBox("bitte das gesuchte Kennzeichen eingeben:", "Fahrzeug suchen und kopieren")
If s = "" Then
MsgBox "Es wurde kein Suchbegriff eingegeben !", vbExclamation, _
"Hinweis für " & Application.UserName & ":"
Exit Sub
End If
gef = False
fiR = 1
laRq = Sheets(bartikel).Cells(Rows.Count, 1).End(xlUp).Row
For I = 1 To laRq
Set SuBe = Sheets(bartikel).Range("A" & fiR).Find(s, lookat:=xlWhole)
If SuBe Is Nothing Then _
Set SuBe = Sheets(bartikel).Range("A" & fiR & ":A" & laRq + 1). _
Find(s, lookat:=xlWhole)
If Not SuBe Is Nothing Then
gef = True
fiR = SuBe.Row + 1
laC = Sheets(bartikel).Cells(SuBe.Row, Columns.Count).End(xlToLeft).Column
za1 = Cells(SuBe.Row, 1).Address(False, False)
za2 = Cells(SuBe.Row, laC).Address(False, False)
Sheets(bartikel).Range(za1 & ":" & za2).copy
'*löscht den gefundenen eintrag
'Sheets(bartikel).Range(za1 & ":" & za2).Delete
laRz = Sheets(barchiv).Cells(Rows.Count, 1).End(xlUp).Row
If laRz = 1 And IsEmpty(Sheets(barchiv).Cells(1, 1)) Then laRz = 0
laRz = laRz + 1
za3 = Cells(laRz, 1).Address(False, False)
za4 = Cells(laRz, laC).Address(False, False)
Sheets(barchiv).Range(za3 & ":" & za4).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Sheets(bartikel).Range(za1 & ":" & za2).Delete
Else
If gef = False Then _
MsgBox "Der Suchbegriff '" & s & "' wurde nicht gefunden !", _
vbExclamation, "Hinweis für " & Application.UserName & ":"
Exit For
End If
Next I
'Call groß
ActiveWorkbook.Save
'Application.WindowState = xlMinimized
End Sub

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: erneute abfrage bis button nein
12.09.2003 08:55:17
Willie
du musst nach vbno bzw. vbyes oder vbcancel abfragen!

bei yes und cancel
goto Anfang

Anfang:
mußt du vor der Eingabe setzen

Gruß

Willie

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige