Döngü ile Değer Bulup Kopyalama

[Anafartalar]

Merhabalar,

Belirtilen koşula göre değer bulup ilgili alanları başka bir sayfaya kopyalayan basit bir dönküye ihtiyacım var. Ekteki dosyada gerekli açıklamayı yaptım yardımcı olursanız sevinirim.

 

[Orion1]

Dosyanız ekte.

Sub aktar()
Dim hcr As Range
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
sat = Sheets("Sayfa2").Cells(65536, "A").End(xlUp).Row + 1
For Each hcr In Range("A2:A" & Cells(65536, "A").End(xlUp).Row)
deg = UCase(Replace(Replace(hcr.Value, "ı", "I"), "i", "İ"))
    If deg = "PORTAKAL" Or deg = "LİMON" Then
        Sheets("Sayfa2").Range(Sheets("Sayfa2").Cells(sat, "A"), Sheets("Sayfa2").Cells(sat, "C")).Value _
        = Range(Cells(hcr.Row, "A"), Cells(hcr.Row, "C")).Value
        sat = sat + 1
    End If
Next
Application.ScreenUpdating = True
MsgBox "İşlem Tamam"
End Sub

 

[Anafartalar]

Evren Bey,

Çok teşekkür ederim. Bende For ve Case döngüler ile yapmayı denemiştim ama olmamıştı. Şimdi bu kodları biraz çözmeyi deneyeyim. Biraz karışık geldi bana

 

[Necdet]

Merhaba,

İstediğiniz For'lu döngü olsun

Private Sub CommandButton1_Click()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
Dim i, j As Long
j = 1
s2.Range("A2:C65536").ClearContents
Application.ScreenUpdating = False
For i = 2 To s1.[A65536].End(3).Row
    If s1.Cells(i, "A") = "Portakal" Or _
       s1.Cells(i, "A") = "Limon" Then
            j = j + 1
            s2.Cells(j, "A") = s1.Cells(i, "A")
            s2.Cells(j, "B") = s1.Cells(i, "B")
            s2.Cells(j, "C") = s1.Cells(i, "C")
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[Anafartalar]

Teşekkür ederim Necdet bey, bu formülü anlamak ve düzenlemek benim için daha kolay.

Herkese iyi Bayramlar