Sayfalar Arası Koşullu Veri Aktarma

[metin_0606]

Değerli üstatlar Ana Sayfa isimli Sayfada bulunan 4500 satırlık veride A İŞLETME yazan çalışma durumu "Etkin" olan personellerin TC kimlik numaralarını Veri sayfasının A2 sütunundan başlamak koşulu ile çekmek istiyorum. Yardımlarınız için şimdiden teşekkürler

 

[Ömer]

Merhaba,

Deneyiniz.

Sub aktar()
    
    Dim S1 As Worksheet, c As Range, Adr As String, sat As Long
 
    Set S1 = Sheets("ANA SAYFA")
 
    Application.ScreenUpdating = False
    Sheets("VERİ").Select
    Range("A2:A" & Rows.Count).ClearContents
 
    sat = 2
    Set c = S1.[X:X].Find("A İŞLETME", , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            If S1.Cells(c.Row, "W") = "Etkin" Then
                Cells(sat, "A") = S1.Cells(c.Row, "B")
                sat = sat + 1
            End If
            Set c = S1.[X:X].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
    
End Sub

 

[metin_0606]

Merhaba,

Deneyiniz.

Sub aktar()
   
    Dim S1 As Worksheet, c As Range, Adr As String, sat As Long

    Set S1 = Sheets("ANA SAYFA")

    Application.ScreenUpdating = False
    Sheets("VERİ").Select
    Range("A2:A" & Rows.Count).ClearContents

    sat = 2
    Set c = S1.[X:X].Find("A İŞLETME", , xlValues, xlWhole)
    If Not c Is Nothing Then
        Adr = c.Address
        Do
            If S1.Cells(c.Row, "W") = "Etkin" Then
                Cells(sat, "A") = S1.Cells(c.Row, "B")
                sat = sat + 1
            End If
            Set c = S1.[X:X].FindNext(c)
        Loop While Not c Is Nothing And c.Address <> Adr
    End If
   
End Sub

[/QUOTE
Teşekkürler Ömer Hocam

 

[schlecht]

merhaba,

If S1.Cells(c.Row, "W") = "Etkin" Then
buraya bir kriter daha nasıl eklerim?

 

[Ömer]

Merhaba,

Deneyiniz.

If S1.Cells(c.Row, "W") = "Etkin" Or S1.Cells(c.Row, "W") = "yenikriter" Then

 

[schlecht]

ben yapamadım sanırım, ayrı ayrı süzüyorda bu şekilde olmadı. teşekkürler cevabınız için

 

[Ömer]

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