Filtre Sonuçlarını Başka Sayfaya Aktarma

[RedStar]

Arkadaşlar iyi geceler

Elimde 2 sayfadan oluşan bir çalışma kitabı var. Benim yapmak istediğim 1. sayfada mesela A sütununu filtreleme yaparak çıkan tüm sonuçları sayfa 2 ye aktarmak istiyorum. Örnek dosyam ve kopyalamak istediğim alana ait resim ektedir. Teşekkür ederim.

 

[ÖmerBey]

Merhaba,
Aşağıdaki kodu deneyiniz.

Sub Kod()
Set s1 = Sheets("1")
Set s2 = Sheets("2")
s1.Range("A:C").SpecialCells(xlCellTypeVisible).Copy s2.Range("A1")
End Sub

 

[RedStar]

Ömer Hocam benim istediğim 1 numaralı sayfada adı bölümünü filtre yaptığımda Tümünü Seç hariç o filtrede ne çıkıyorsa resimdede kare içerisine aldığım yeri 2 nolu sayfaya kopyalamak istiyorum. Teşekkür ederim.

 

[ÖmerBey]

Doğru anlamışsam A sütunundaki kayıtları benzersiz liste olarak almak istiyorsunuz. Bunun için aşağıdaki kodu kullanabilirsiniz.
Alternatif olarak veri sekmesinden gelişmiş filtre seçeneklerini de kullanabilirsiniz.

Sub Kod()
Set S1 = Sheets("1")
Set s2 = Sheets("2")
S1.Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s2.Range("A1"), Unique:=True
End Sub

Eğer istediğiniz olmazsa örnek dosyanızın 2. sayfasına görmek istediğiniz sonucu ekleyiniz.
İyi çalışmalar...

 

[çıtır]

Deneyiniz.

Sub Kopya()
Application.ScreenUpdating = False
Dim s1 As Worksheet: Dim s2 As Worksheet
Set s1 = Sheets("1"): Set s2 = Sheets("2")
son = s1.Cells(36355, "A").End(3).Row
s2.Range("A1:A" & Rows.Count).Cells.Clear
s1.Range("A1:A" & son).Select
Selection.Copy
s2.Select
s2.Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[RedStar]

Doğru anlamışsam A sütunundaki kayıtları benzersiz liste olarak almak istiyorsunuz. Bunun için aşağıdaki kodu kullanabilirsiniz.
Alternatif olarak veri sekmesinden gelişmiş filtre seçeneklerini de kullanabilirsiniz.

Sub Kod()
Set S1 = Sheets("1")
Set s2 = Sheets("2")
S1.Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s2.Range("A1"), Unique:=True
End Sub

Eğer istediğiniz olmazsa örnek dosyanızın 2. sayfasına görmek istediğiniz sonucu ekleyiniz.
İyi çalışmalar...

Hocam yapmak istediğim adı bölümünde mükerrer kayıtlar var ben bunları silmeden 2 numaralı sayfaya mükerrer olan ve olmayan verileri listelemek ve veri mükerrer ise kaç tane olduğunu mükerrer değil ise 1 olarak yazmasını istiyordum. Teşekkür ederim zahmet veriyorum. Dosyayı tekrar istediğiniz şekilde hazırladım ekledim.

 

[ÖmerBey]

Tekrar merhaba,
Aşağıdaki makro kodları örnek dosyanızda belirttiğiniz sonucu veriyor, deneyiniz...

Sub Kod()
Set s1 = Sheets("1")
Set s2 = Sheets("2")
s1.Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s2.Range("A1"), Unique:=True
s2.Range("B1") = "SAYISI"
For a = 2 To s2.Cells(s2.Rows.Count, "A").End(3).Row
    s2.Cells(a, "B") = WorksheetFunction.CountIf(s1.Range("A:A"), s2.Cells(a, "A"))
Next
End Sub

 

[RedStar]

Tekrar merhaba,
Aşağıdaki makro kodları örnek dosyanızda belirttiğiniz sonucu veriyor, deneyiniz...

Sub Kod()
Set s1 = Sheets("1")
Set s2 = Sheets("2")
s1.Range("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=s2.Range("A1"), Unique:=True
s2.Range("B1") = "SAYISI"
For a = 2 To s2.Cells(s2.Rows.Count, "A").End(3).Row
    s2.Cells(a, "B") = WorksheetFunction.CountIf(s1.Range("A:A"), s2.Cells(a, "A"))
Next
End Sub

İşin gücün rast gelsin hocam çok teşekkürler. Makro mükemmel çalışıyor tek bir sıkıntı gözüme çarptı 1 nolu sayfadaki verilerden birini satır sil yapmadan silersen veri olmayan bir hücre ve sayı bölümünede 0 yazıyor . Satır silerek yaparsakta sayı bölümünde sayılar kalıyor.

 

[çıtır]

Bu da benim alternatifim olsun.

Sub kopyala()
Application.ScreenUpdating = False
Dim s1 As Worksheet: Dim s2 As Worksheet: Dim i As Integer
Set s1 = Sheets("1"): Set s2 = Sheets("2")
s2.Range("A2:B" & Rows.Count).Cells.Clear
s1.Select
s1.Range("A1:A" & Rows.Count).Cells.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=s2.Range("A1"), Unique:=True
son1 = s1.Cells(65335, "A").End(3).Row
son2 = s2.Cells(65335, "A").End(3).Row
For i = 2 To son2
s2.Cells(i, 2) = WorksheetFunction.CountIf(s1.Range("A2:A" & son1), s2.Range("A" & i))
Next i
Application.ScreenUpdating = True
End Sub

 

[ÖmerBey]

Bu bir sıkıntı değil, sizin isteğiniz.

1 numaralı sayfada adı bölümünü filtre yaptığımda Tümünü Seç hariç o filtrede ne çıkıyorsa resimdede kare içerisine aldığım yeri 2 nolu sayfaya kopyalamak istiyorum

1 nolu sayfadaki verilerden birini satır sil yapmadan sildiğiniz zaman filtrede ne çıktığına bakar mısınız?
Sayıların kalmaması için kırmızı eklentiyi yapabilirsiniz.

Set s2 = Sheets("2")
s2.Range("A:B").ClearContents

 

[ÖmerBey]

Sayın @RedStar konuyu filtre olarak sorduğunuz için hep filtre üzerinden çözüm üretmeye çalıştım, ancak zannedersem sizin çözümünüz aşağıdaki şekildedir, deneyiniz.
İyi çalışmalar diliyorum...

Sub Kod()
Set s1 = Sheets("1")
Set s2 = Sheets("2")
s2.Range("A:B").ClearContents
s2.Range("A1") = "ADI"
s2.Range("B1") = "SAYISI"
x = 2
For a = 2 To s1.Cells(s1.Rows.Count, "A").End(3).Row
    If WorksheetFunction.CountIf(s1.Range("A2:A" & a), s1.Cells(a, "A")) = 1 Then
        s2.Cells(x, "A") = s1.Cells(a, "A")
        s2.Cells(x, "B") = WorksheetFunction.CountIf(s1.Range("A:A"), s1.Cells(a, "A"))
        x = x + 1
    End If
Next
End Sub

 

[RedStar]

Ömer hocam satır sil yapmadan veri silince filtrede veri silinen satırdan sonraki yazılan veriler gözükmüyor ama makroyu çalıştırınca 2. sayfada silinen verilen boş olarak sayı bölümüde 0 olarak gözüküyor.

Sayı kalmaması için verdiğiniz kodda mükemmel çalışıyor. Ekran alıntılarını ekliyorum hocam.

 

[RedStar]

Sayın @ÖmerBey ve Sayın @çıtır emekleriniz için çok teşekkür ederim.

 

[ÖmerBey]

Rica ederim
Biraz önceki mesajda filtreyle ilgili "sizin isteğiniz" derken kastettiğim şuydu:
11 numaralı mesajdaki kodu kullanabilirsiniz. İyi çalışmalar...

 

[RedStar]

Sayın @RedStar konuyu filtre olarak sorduğunuz için hep filtre üzerinden çözüm üretmeye çalıştım, ancak zannedersem sizin çözümünüz aşağıdaki şekildedir, deneyiniz.
İyi çalışmalar diliyorum...

Sub Kod()
Set s1 = Sheets("1")
Set s2 = Sheets("2")
s2.Range("A:B").ClearContents
s2.Range("A1") = "ADI"
s2.Range("B1") = "SAYISI"
x = 2
For a = 2 To s1.Cells(s1.Rows.Count, "A").End(3).Row
    If WorksheetFunction.CountIf(s1.Range("A2:A" & a), s1.Cells(a, "A")) = 1 Then
        s2.Cells(x, "A") = s1.Cells(a, "A")
        s2.Cells(x, "B") = WorksheetFunction.CountIf(s1.Range("A:A"), s1.Cells(a, "A"))
        x = x + 1
    End If
Next
End Sub

Hocam kod mükemel çalışıyor öncelikle teşekkür ederim. Anasayfa isimli bir sayfadaki K2 ile K1500 arasında sütünda yer alanları benzersiz olarak kaç tane yer aldığını Olay isimli sayfaya nasıl aktarabilirim ? Bu kodun neresinde ne değişiklik yapmam gerekiyor ?

Sub Kod()
Set s1 = Sheets("Anasayfa")
Set s2 = Sheets("Olay")
s2.Range("A:B").ClearContents
s2.Range("A1") = "ADI"
s2.Range("B1") = "SAYISI"
x = 2
For a = 2 To s1.Cells(s1.Rows.Count, "K").End(3).Row
    If WorksheetFunction.CountIf(s1.Range("K2:K1500" & k), s1.Cells(k, "K")) = 1 Then
        s2.Cells(x, "A") = s1.Cells(k, "K")
        s2.Cells(x, "B") = WorksheetFunction.CountIf(s1.Range("K:K"), s1.Cells(k, "K"))
        x = x + 1
    End If
Next
End Sub

bu şekilde yaptım
Run-time error '1004':
Application-defined or object-defined error

 

[RedStar]

Merhaba 2 sayfadan oluşan bir çalışma kitabım var. 1.sayfadaki A sütünunda yer alan verileri benzersiz olarak 2.sayfadaki A sütununa isim olarak B sütununa ise 1. sayfa A sütununda girilen verinin kaç defa tekrar ettiğini sayısal olarak yazdırıyor. Buraya kadar Sayın @ÖmerBey ve Sayın @çıtır yardımları ile konuyu hallettim.

Bugün ise ufak bir geliştirme ihtiyacı hasıl oldu. 2 isimli çalışma sayfasına c sütununa sabah d sütununa akşam e sütununa gece isimli 1 numaralı Vardiya sütununa yer alan verileri benzersiz olarak sütün başlığı olarak ekledim.

Yapmak istediğim 1.sayfadaki isimleri benzersiz olarak saysın 2. Sayfadaki adı ve sayısı bölümlerine yazsın. Mesela Mehmet verisini saydı 2.sayfada Adı bölümüne Mehmet yazdı Sayısı bölümüne 3 yazdı bundan sonra 1. Sayfadaki C sütünunda yer alan Vardiya altındaki Sabah, akşam ve gece sayısına bakarak 2.sayfadaki başlıklarının altına sayı olarak yazsın veri ismini karşılamıyorsa 0 olarak yazsın istiyorum.
İlgi ve alakanıza teşekkür ederim.

 

[çıtır]

Deneyiniz.

Sub vardıyasay()
Application.ScreenUpdating = False
Dim s1 As Worksheet: Dim s2 As Worksheet: Dim i As Integer
Set s1 = Sheets("1"): Set s2 = Sheets("2"): Set wf = WorksheetFunction
s2.Range("A2:E" & Rows.Count).Cells.Clear
s1.Select
s1.Range("A1:A" & Rows.Count).Cells.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=s2.Range("A1"), Unique:=True
son1 = s1.Cells(65335, "A").End(3).Row
son2 = s2.Cells(65335, "A").End(3).Row
s2.Select
s2.Range("A2:A" & son2).Sort Range("A2"), xlAscending
s2.Cells(1, 2) = "SAYISI": s2.Cells(1, 3) = "Sabah": s2.Cells(1, 4) = "Akşam": s2.Cells(1, 5) = "Gece"
For i = 2 To son2
s2.Cells(i, 2) = wf.CountIf(s1.Range("A2:A" & son1), s2.Range("A" & i))
s2.Cells(i, 3) = wf.CountIfs(s1.Range("A2:A" & son1), s2.Range("A" & i), s1.Range("C2:C" & son1), s2.Range("C1"))
s2.Cells(i, 4) = wf.CountIfs(s1.Range("A2:A" & son1), s2.Range("A" & i), s1.Range("C2:C" & son1), s2.Range("D1"))
s2.Cells(i, 5) = wf.CountIfs(s1.Range("A2:A" & son1), s2.Range("A" & i), s1.Range("C2:C" & son1), s2.Range("E1"))
Next i
Application.ScreenUpdating = True
MsgBox "İşlem Tamam.", vbInformation
End Sub

 

[Ziynettin]

Altenatif.

Sub kod()
With Sheets("1")
    son = .Cells(Rows.Count, 1).End(xlUp).Row
    a = .Range("A2:C" & son).Value
End With

Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")

    For i = 1 To UBound(a)
        d1(a(i, 1)) = ""
        d2(a(i, 3)) = ""
        krt = a(i, 1) & "|" & a(i, 3)
        d3(krt) = d3(krt) + 1
    Next i

    sat = d1.Count
    sut = d2.Count
    
    If sat > 0 Then
        ReDim b(1 To sat, 1 To sut + 1)
        For i = 1 To sat
            For j = 1 To sut
                krt = d1.keys()(i - 1) & "|" & d2.keys()(j - 1)
                b(i, 1) = b(i, 1) + d3(krt)
                b(i, j + 1) = d3(krt)
            Next j
        Next i
        With Sheets("2")
            .Cells = ""
            .[C1].Resize(, sut) = d2.keys
            .[A2].Resize(sat) = Application.Transpose(d1.keys)
            .[B2].Resize(sat, sut + 1) = b
            .[A1] = "ADI"
            .[B1] = "SAYISI"
        End With
    End If
MsgBox "İşlem Tamam.", vbInformation
End Sub

 

[RedStar]

sayın @çıtır sayın @Ziynettin çok teşekkür ederim

 

[çıtır]

sayın @çıtır sayın @Ziynettin çok teşekkür ederim

Rica ederim.Dönüş yaptığınız için teşekkür ederim.