suchen dann kopieren und dann löschen
07.09.2003 21:06:20
Franzel
habe ein Problem und hoffe ihr könnt mir helfen.
Ich habe eine Tabelle "Artikel" in die daten eingegeben werden. Später wird in dieser Tabelle ein artikel gesucht über eine eingabemaske. Wenn dieser artikel gefunden wurde soll die ganze zeile in eine zweite tabelle an eine bestimmte stelle eingefügt werden. Wenn dann der artikel in die zweite tabelle eingefügt wurde soll der artikel aus der ersten tabelle gelöscht werden. Habe mir schon verschiedene Code´s aus dem forum geholt. Bin aber wohl zu bl........
könnt Ihr mir bitte helfen ??
zur verdeutlichung hier der code
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
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
Else
If gef = False Then _
MsgBox "Der Suchbegriff '" & s & "' wurde nicht gefunden !", _
vbExclamation, "Hinweis für " & Application.UserName & ":"
Exit For
End If
Next i
Löschen
End Sub