İÇERİR KRİTERLERİ FARKLI SAYFAYA ÇEKME

[Astalavista58]

Merhaba hayırlı günler. Benim yapmak istediğim, Sayfa1'de H2 VE I2 girdiğim kriterleri içeren personel bilgilerini Sayfa2'ye çeksin

 

[Orion1]

Buyurun.

Sub aktar()
Dim s1 As Worksheet, s2 As Worksheet, sonsat As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A:F").ClearContents
s1.Range("A:F").AutoFilter
s1.Range("A:F").AutoFilter field:=5, Criteria1:=s1.Range("H2").Value
s1.Range("A:F").AutoFilter field:=6, Criteria1:=s1.Range("I2").Value
s1.Range("A:F").CurrentRegion.Copy s2.Range("A1")
s1.Range("A1").AutoFilter
MsgBox "İşlem Tamamlandı"
End Sub

 

[Muzaffer Ali]

Merhaba.
Alternatif olsun.
Sayfa1 A:F aralığına çift tıklama ile Sayfa2 ye otomatik aktarılır.
Aşağıdaki kodu Sayfa1'in kod kısmına kopyalayın, Sayfa1 A:F aralığındaki dolu hücrelere çift tıklatın.

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    Dim Say As Integer
    Dim Bul As Range
    Dim Bak As Integer
    Dim SNo As Integer
    If Not Intersect(Target, Range("A:F")) Is Nothing And Not Target = "" Then
        With Worksheets("Sayfa2")
            Say = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            Set Bul = .Range("B:B").Find(Range("B" & Target.Row), Lookat:=xlWhole)
            If Bul Is Nothing Then
                .Range("A" & Say) = Say - 1
                Range("B" & Target.Row & ":F" & Target.Row).Copy .Range("B" & Say)
                Range("A" & Target.Row & ":F" & Target.Row).Interior.Color = 65535
            Else
                Range("A" & Target.Row & ":F" & Target.Row).Interior.Pattern = xlNone
                .Range("A" & Bul.Row & ":F" & Bul.Row).Delete xlShiftUp
                For Bak = 2 To Say - 2
                    SNo = SNo + 1
                    .Cells(Bak, "A") = SNo
                Next
            End If
        End With
        Application.CutCopyMode = False
    End If
End Sub

 

[Astalavista58]

Çok teşekkür Allah razı olsun

 

[Astalavista58]

Buyurun.

Sub aktar()
Dim s1 As Worksheet, s2 As Worksheet, sonsat As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
s2.Range("A:F").ClearContents
s1.Range("A:F").AutoFilter
s1.Range("A:F").AutoFilter field:=5, Criteria1:=s1.Range("H2").Value
s1.Range("A:F").AutoFilter field:=6, Criteria1:=s1.Range("I2").Value
s1.Range("A:F").CurrentRegion.Copy s2.Range("A1")
s1.Range("A1").AutoFilter
MsgBox "İşlem Tamamlandı"
End Sub

Hocam hayırlı akşamalar, bir konuda daha yardık isteyecektim. Formül çok güzel çalışıyor ancak "H2" hücresine veri girmeyince sadece "I2" hücresindeki veriye göre veri çekme işlemi yapacak şekilde formülü revize etme şansımız var mı.

 

[ÖmerFaruk]

If s1.Range("H2")<>"" Then s1.Range("A:F").AutoFilter field:=5, Criteria1:=s1.Range("H2").Value

 

[Astalavista58]

Ömer Faruk hocam elinize sağlık çok teşekkür ederim