A sütununda yazan değere göre satır taşıma

[tukayf]

Değerli hocalarım açıklamayı ek içerisinde yaptım. A sütununda yazan değere göre tüm satırı taşımak istiyorum. Elimdeki kod çok yavaş çalıştığı için farklı çözüm aramak durumunda kaldım. Yanıtlar için şimdiden çok teşekkürler

 

[tukayf]

Sub SatirTasi()
    Dim aranacakKelime As String
    Dim hedefSayfa As String
    Dim sonSatir As Long
    Dim i As Long
    
    aranacakKelime = InputBox("Taşınacak satırları içeren kelimeyi girin: ")
    hedefSayfa = InputBox("Hedef sayfa adını girin: ")
    sonSatir = Range("A" & Rows.Count).End(xlUp).Row
    
    For i = sonSatir To 1 Step -1
        If Cells(i, 1).Value = aranacakKelime Then
            Rows(i).Cut Destination:=Sheets(hedefSayfa).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
        End If
    Next i
    
End Sub

Yapay zeka ile gayet hızlı bir çözüm bulabildim.

 

[Necdet]

Merhaba,

Aşağıdaki kodları dener misiniz? Hızını merak ediyorum. Sonucu paylaşırsanız sevinirim.

Sub Makro1()
   
    Dim Aranan As Variant
    Dim i As Long
    Dim j As Integer
    Dim k As Long
   
    Dim arr As Variant
    Dim ar As Variant
   
    On Error Resume Next
    Application.ScreenUpdating = False
   
    Aranan = Application.InputBox("Aranacak Sözcüğü Giriniz", "Arama", Type:=2)
    If Aranan = False Or Aranan = "" Then Exit Sub
    Aranan = Evaluate("=UPPER(" & """" & Aranan & """" & ")")

    k = Sheets("tayin").Cells(Rows.Count, "A").End(3).Row
    i = Sheets("sube").Cells(Rows.Count, "A").End(3).Row
   
    arr = Sheets("sube").Range("A4:W" & i).Value
    ar = Sheets("sube").Range(Cells(4, "A"), Cells(4, UBound(arr, 2))).Value
   
    For i = 2 To UBound(arr, 1)
        If Evaluate("=UPPER(" & """" & arr(i, 1) & """" & ")") = Aranan Then
            k = k + 1
            For j = 1 To UBound(arr, 2)
                ar(1, j) = arr(i, j)
                arr(i, j) = ""
            Next j
            Sheets("tayin").Range("A" & k).Resize(1, UBound(arr, 2)) = ar
           
        End If
    Next i
   
    Sheets("sube").Range("A4").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
   
    i = Sheets("sube").Cells(Rows.Count, "A").End(3).Row
    If i > 5 Then Range("A4:A" & i).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
       
    Application.ScreenUpdating = True
    MsgBox "işlem Tamamdır...."
   
End Sub

 

[tukayf]

Sn. Necdet hocam sizin kodlarınız eski kullandığım koda göre fevkalade hızlı. Ama yapay zeka koduna göre yavaş. Bunun sebebi ise yapay zeka satırı taşırken sayfadaki satırı komple taşımıyordu sadece verileri alıp taşıyor daha sonra ben tekrar listeleme yapıyordum. Ama sizin kodunuzda bu sorun ortadan kalkmış oldu. Yanıtınız için teşekkür ederim. Artık sizin kodlarını kullanacağım.

 

[Necdet]

Merhaba,
kodlara dikkat ettiyseniz karşılaştırma yaparken hepsini büyük harfe çeviriyor, bu da doğal olarak süreyi uzatır.
Ayrıca silinen veriyi de sayfadan siliyorum.

bunlar da doğal olarak işlemi yavaşlatır.

 

[tukayf]

Hocam zihninize sağlık çok teşekkürler.