• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

  • Konbuyu başlatan Konbuyu başlatan RedStar
  • Başlangıç tarihi Başlangıç tarihi
R

RedStar

Altın Üye
Katılım
16 Temmuz 2006
Mesajlar
144
Excel Vers. ve Dili
Excel 2013 Dil Türkçe
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.

veri alma.png
 

Ekli dosyalar

Merhaba,
Aşağıdaki kodu deneyiniz.
PHP: 
Sub Kod()
Set s1 = Sheets("1")
Set s2 = Sheets("2")
s1.Range("A:C").SpecialCells(xlCellTypeVisible).Copy s2.Range("A1")
End Sub
 
Ö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.
 
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.
PHP: 
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...
 
Deneyiniz.
Kod: 
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
 
Son düzenleme:
ÖmerBey' Alıntı:
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.
PHP: 
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...
Genişletmek için tıkla ...

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.
 

Ekli dosyalar

Tekrar merhaba,
Aşağıdaki makro kodları örnek dosyanızda belirttiğiniz sonucu veriyor, deneyiniz...
PHP: 
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
 
ÖmerBey' Alıntı:
Tekrar merhaba,
Aşağıdaki makro kodları örnek dosyanızda belirttiğiniz sonucu veriyor, deneyiniz...
PHP: 
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
Genişletmek için tıkla ...

İş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.
 
Bu da benim alternatifim olsun.
Kod: 
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
 
Bu bir sıkıntı değil, sizin isteğiniz.
RedStar' Alıntı:
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
Genişletmek için tıkla ...
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
Genişletmek için tıkla ...
 
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...
PHP: 
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
 
Ö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.1.png2.png3.png
 
Rica ederim
Biraz önceki mesajda filtreyle ilgili "sizin isteğiniz" derken kastettiğim şuydu:
11 numaralı mesajdaki kodu kullanabilirsiniz. İyi çalışmalar...
 

Ekli dosyalar

  • q.jpg
    q.jpg
    31.7 KB · Görüntüleme: 19
ÖmerBey' Alıntı:
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...
PHP: 
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
Genişletmek için tıkla ...

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 ?

Kod: 
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
 
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.
 

Ekli dosyalar

Deneyiniz.
Kod: 
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
 
Son düzenleme:
Altenatif.

Kod: 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst