past spezial methode des range objektes
10.09.2003 21:41:18
franzel
ich nochmal nach dem ich nun den code zu suchen kopieren und löschen habe stoße ich auf das nächste problem.
In Tabelle1 wird der gefunden wert in eine 2 tabelle kopier " sollte zumindest"
bekomme aber die fehlermeldung paste spezial - Methode des Range objektes ....
zur verdeutlichung hier der code
im unteren teil zwischen den sternschen befindet sich das problem
vor ab schon einmal danke für Eure hilfe
mfg
franzel
Sub ladeliste()
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
'Call kundenname
Sheets("artikel").Select
Const bartikel As String = "artikel"
Const barchiv As String = "tabelle1"
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, 9).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:=xlAllExceptBorders, 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
speichern
Sheets("Ladeliste").Select
Range("B2:B7,A10:f26").Select
Selection.ClearContents
Range("A10").Activate
Sheets("Artikel").Select
End Sub