diğer sayfalardan koşullu veri aktarımı ve silinmesi

[hüseyintok]

Merhaba aşağıda sayfa1 den 4 e kadar sheetler bulunmaktadır. a kolununda sadece "Hayir" olanları veri "Sheet5" dosyasında toplamak istiyorum. Eğer koşul diğer sayfalarda "Hayir" a dönmüş ise veri dosyasından "sheet5" den silinmesini istiyorum. aşağıda makrom var ama çalıştıramıyorum hata veriyor. yardımcı olurmusunuz.


Sub aktar()

son = Range("x4").End(xlDown).Row
For i = 4 To son
If Cells(i, "X") = "Hayir" Then
Sheet1.Range("a" & i & ": w" & i).Copy
Sheet5.Range("a6").End(xlDown).Offset(1, 0).PasteSpecial xlPasteAll
Sheet2.Range("a" & i & ": w" & i).Copy
Sheet5.Range("a6").End(xlDown).Offset(1, 0).PasteSpecial xlPasteAll
Sheet3.Range("a" & i & ": w" & i).Copy
Sheet5.Range("a6").End(xlDown).Offset(1, 0).PasteSpecial xlPasteAll
Sheet4.Range("a" & i & ": w" & i).Copy
Sheet5.Range("a6").End(xlDown).Offset(1, 0).PasteSpecial xlPasteAll
Application.CutCopyMode = False
End If
Next

If Target.Column = 24 Then
If Target.Value = "evet" Then
Set bul = Sayfa2.Range("a4:a500").Find(Cells(Target.Row, 1), LookIn:=xlValues)
If Not bul Is Nothing Then
Sayfa2.Cells(bul.Row, 1).EntireRow.Delete shift:=xlUp

End If
End If
End If
End If


MsgBox "Islem tamam...", vbInformation, "hsyn"
End Sub

 

[Ömer]

Merhaba,

Deneyiniz.

Sub aktar()
    
    Dim i As Byte, syf As Worksheet, sat As Long, c As Range, Adr As String
    
    Application.ScreenUpdating = False
    Sheets("veri").Select
    Range("A5:G" & Rows.Count).Clear
    
    sat = 5
    For i = 1 To 4
        Set syf = Sheets("" & i & "")
        Set c = syf.[A:A].Find("hayir", , xlValues, xlWhole)
        If Not c Is Nothing Then
            Adr = c.Address
            Do
                syf.Cells(c.Row, "A").Resize(1, 7).Copy Cells(sat, "A")
                sat = sat + 1
                Set c = syf.[A:A].FindNext(c)
            Loop While Not c Is Nothing And c.Address <> Adr
        End If
    Next i
    
    Application.ScreenUpdating = True
    
End Sub

 

[hüseyintok]

teşekkürler.

 

[hüseyintok]

Merhaba, Bu örnekte Sheet isimleri numaradan oluşuyor ve çalışıyor fakat, Sheet isimleri Karakter, kelime olduğunda çalıştıramadım. Örneğin "Sheet1= ahmet, Sheet2=mehmet, Sheet3=ayşe" gibi bu konuda yardımcı olabilirmisiniz mackroyu uğraştım ama düzeltemedim.

 

[Ömer]

Merhaba,

Kaç adet sayfa var? Eğer sayfalar fazlaysa kodların içine yazmak yerine tüm sayfalarda döngüye girilebilir ve istenmeyen sayfalar dışarıda tutulabilir.

Örnek dosya ekleyerek açıklar mısınız.

 

[hüseyintok]

Ömer bey, Ekte ki örnek dosyada Sheet = Ahmet, Mehmet, Kazım, Ayse isminde olanlardan Data alınıp Veri Sheetine koşulların gelmesini istiyorum. Atil, Atil2, Atil3 olan Sheetlerden herhangi bir data gelmemesi gerekiyor. İlginiz için teşekkür ederim.
Saygılar.

 

[Ömer]

Deneyiniz.

Sub aktar1()
    
    Dim syf As Worksheet, sat As Long, c As Range, Adr As String
    
    Application.ScreenUpdating = False
    Sheets("veri").Select
    Range("A5:G" & Rows.Count).Clear
    
    sat = 5
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name Like "atil*" And syf.Name <> "veri" Then
            Set c = syf.[A:A].Find("hayir", , xlValues, xlWhole)
            If Not c Is Nothing Then
                Adr = c.Address
                Do
                    syf.Cells(c.Row, "A").Resize(1, 7).Copy Cells(sat, "A")
                    sat = sat + 1
                    Set c = syf.[A:A].FindNext(c)
                Loop While Not c Is Nothing And c.Address <> Adr
            End If
        End If
    Next syf
    
    MsgBox "Aktarım bitti.", vbInformation
    Application.ScreenUpdating = True
    
End Sub

 

[hüseyintok]

Meraba Ömer bey, veri dosyasına aktarım yaparken son hayir koşulunu sağlayan satır ile birlikte altında ki evet olan 2 satırı da getiriyor. neden olabilir?

 

[Ömer]

Eklediğiniz dosyada denedim sadece "hayir" ları getiriyor. Hata aldığınız örnek dosyayı ekler misiniz.

 

[hüseyintok]

Sorunu çözdüm. Teşekkürler Emeklerinize sağlık.
Kolay gelsin