Hücre değerine göre bul, kes, yapıştır için kod

[KARTAL06]

Merhaba
Sorum şu bir sipariş listem var A1:M:200 alanında (sarı renkli alan) bu alanda L kolonundaki "et" yada "ET" yazılı satırları keserek aktif sayfanın 201. satırından itibaren yapıştırmak. Dosya ekte.
Daha önce sayfadan sayfaya yapan benzer bir kod vardı ama modfiye edemedim.
Şimdiden teşekkür edrim.

 

[NBATMAN]

Aşağıdaki kodları deneyiniz... bir commandbutton ekleyip commandbuton için aşağıdaki kodları kullanınız.N1 hücresine süzme kriterinizi ( ET ) yazınız .

Private Sub CommandButton1_Click()
Dim Son As Long
Sayfa1.Select
Sayfa1.Range("a201:m210").Clear
Son = Sayfa1.[A65536].End(3).Row
ActiveSheet.Range("A1:M" & Son).AutoFilter Field:=12, Criteria1:=Sayfa1.Range("N1").Value
ActiveSheet.Range("A1:M" & Son).Copy
Sayfa1.Range("a201").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.AutoFilter
Application.CutCopyMode = False
Sayfa1.Range("a201").Select
End Sub

 

[janveljan]

İlgili satırı bu şekilde değiştirip kullanırsanız doğru sonuç alacaksınız.

Son = Sayfa1.[F65536].End(3).Row

 

[KARTAL06]

Gecikme için özür dilerim. Evimde pc yok. İş yerinden takip edebiliyorum.
Öncelikle her ikinizide teşekkür ederim.

Aşağıdaki kodları deneyiniz... bir commandbutton ekleyip commandbuton için aşağıdaki kodları kullanınız.N1 hücresine süzme kriterinizi ( ET ) yazınız .

Private Sub CommandButton1_Click()
Dim Son As Long
Sayfa1.Select
Sayfa1.Range("a201:m210").Clear
Son = Sayfa1.[A65536].End(3).Row
ActiveSheet.Range("A1:M" & Son).AutoFilter Field:=12, Criteria1:=Sayfa1.Range("N1").Value
ActiveSheet.Range("A1:M" & Son).Copy
Sayfa1.Range("a201").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.AutoFilter
Application.CutCopyMode = False
Sayfa1.Range("a201").Select
End Sub

İlgili satırı bu şekilde değiştirip kullanırsanız doğru sonuç alacaksınız.

Son = Sayfa1.[F65536].End(3).Row

Sn janveljan uyarısınıda dikkate alarak kodu düzelltim ama kesme işlemini yapmadı üst listede ET satırları hala duruyor. Ayrıca Sayfa1.[F65536].End(3).Row neden "F" aslında bu Tablonun her kolonu dolu özel parça numaraları olduğu için o kısımları boşaltmıştım "A" olarak değiştirmenin bir mahsuru olurmu?

 

[KARTAL06]

Kimsenin dikkatini çekmedi herhelde.

3 gündür kafama takıldı ve çözemedim.

 

[janveljan]

Dediğiniz gibi kodlar kopyalamaya göre ayarlı idi, yeniden düzenledim, birde bunu deneyin. Kriteri kodların içinde yazdım, siz gerekli düzenlemeyi yaparsınız. F sütunu konusuna gelince, tablonun tamamı dolu ise A demenizde sakınca yok. Kodları çalıştıcağınız dosyada Sayfa2 diye ayrı bir sayfa olması lazım.

Sub kes_yapıştır()
Set sf1 = Sheets("Sayfa1")
Set sf2 = Sheets("Sayfa2")
kriter = "harun"
'kriter = sf1.Range("N1")
sf1.Cells(1, 1).EntireRow.Copy sf2.Cells(1, 1)
For i = sf1.[F65536].End(xlUp).Row To 2 Step -1
    If sf1.Cells(i, "L") = kriter Then
        sf1.Cells(i, 1).EntireRow.Cut sf2.Cells(sf2.[F65536].End(xlUp).Row + 1, 1)
        sf1.Cells(i, 1).EntireRow.Delete Shift:=xlUp
    End If
Next
End Sub