• DİKKAT

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

Filtreleme ve Belirli Sayıda Veri Aktarımı.

C

ccuneyt13

Altın Üye
Katılım
20 Ocak 2011
Mesajlar
478
Excel Vers. ve Dili
Office 365 Türkçe (64 bit)
Elim de 5 İL'e ait abone borç listesi bulunmakta ve çeşitli aşamalardan sonra oluşan listede "Q" sütününda 1000 TL üstü olan ve olmayanlar işaretleniyor.


Öncelikle AFYON sekmesinde var olan liste içerisinden "Q" sütününda "1000 TL ÜST" yazanların süzüp ilgili sekmesi olan "Afyon 1000" içine başlıkdan sonraki satırdan itibaren kopyalamak istiyorum. Diğer İllerinkide gene ilgili sekmelere;

Diğeri ise yine örnek "AFYON" sekmesindeki listenin başlıkdan sonraki ilk 100 sırayı yani 2. sıradan 101. sıraya kadar olan listeyi de gene o İlle alakalı olan "AFYON İLK 100" sekmesi içersine kopyalamak istiyorum.

Emeği geçen, geçmeyen, vakit ayıran, ayıramayan herkese saygılar sevgiler şimdiden.

Örnek Dosyam Ek'te dir.
 

Ekli dosyalar

Son düzenleme:
"AFYON" için Afyon 1000" ve "AFYON İLK 100" için gereken kodları verebilirseniz diğer iller için uyarlayabilirim.

Teşekkürler.
 
Herkese günaydın. Konuyla ilgili yardımcı olabilecek varmı?
 
Merhaba,

Q sütununda 1000 TL ÜST değerin üzerinde başka değer var mı?
 
Merhaba,

Aşağıdaki kodu denermisiniz.

Kod: 
Sub AKTAR()
    Dim X As Long
    
    Application.ScreenUpdating = False
    
    For X = 6 To 17
        Sheets(X).Range("A2:Q" & Rows.Count).ClearContents
    Next
    
    For X = 1 To 5
        Sheets(X).Range("A1").AutoFilter Field:=17, Criteria1:="1000 TL ÜST"
        Sheets(X).Range("A1").CurrentRegion.Copy Sheets(Sheets(X).Name & " 1000").Range("A1")
        Sheets(X).Range("A1").CurrentRegion.Copy Sheets("1000 tl GENEL").Range("A" & Rows.Count).End(3)(1)
        Sheets(Sheets(X).Name & " 1000").Range("A1:Q101").Copy Sheets(Sheets(X).Name & " İLK 100").Range("A1")
        Sheets(Sheets(X).Name & " 1000").Range("A1:Q101").Copy Sheets("GENEL İLK 100").Range("A" & Rows.Count).End(3)(1)
    Next
 
    For X = Sheets("1000 tl GENEL").Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        If Sheets("1000 tl GENEL").Cells(X, 1) = "İşletme" Then Sheets("1000 tl GENEL").Rows(X).Delete
    Next
 
    For X = Sheets("GENEL İLK 100").Cells(Rows.Count, 1).End(3).Row To 2 Step -1
        If Sheets("GENEL İLK 100").Cells(X, 1) = "İşletme" Then Sheets("GENEL İLK 100").Rows(X).Delete
    Next
 
    For X = 1 To 5
        Sheets(X).Range("A1").AutoFilter
    Next
 
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Merhaba,

Korhan bey yanıtlamış bende birşeyler yapmıştım, alternatif olsun.

Aşağıdaki kodlar ThisWorkbook'un kod sayfasında olmalı.

Herhangi bir sayfada, herhangi bir hücreye çift tıkladığınızda kod çalışır.
İlgili sayfada süz işlemi yaptıysanız ve ölçütünüz de "1000 TL ÜSTÜ" ise süzülen veriler ilgili sayfaya (Sayfa yoksa açılır) aktarılır, aksi halde yine aktif sayfada ilk 100 satır yine ilgili sayfaya (Sayfa Yoksa Açılır) aktarılır.

Kod: 
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If ActiveSheet.Name Like "*1000" Then Exit Sub
    
    On Error Resume Next
    
    Dim Syf As String
    Dim i   As Long
    Dim j   As Long
    Dim Ana As Worksheet
    Dim Olcut As String
    
    Set Ana = ActiveSheet
        
    With ActiveSheet
        If .AutoFilterMode Then
            With .AutoFilter.Filters(17)
                If .On Then Olcut = .Criteria1
            End With
        End If
    End With
            
    If Olcut Like "*ÜST" Then
        Syf = ActiveSheet.Name & " 1000"
    Else
        Syf = ActiveSheet.Name & " İLK YÜZ"
        ActiveSheet.ShowAllData
        i = Ana.Cells(Rows.Count, "A").End(3).Row
        If i > 101 Then i = 101
    End If
        
    If SayfaVarYok(Syf) = False Then
        Worksheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Syf
        Ana.Range("1:1").Copy Range("A1")
        Ana.Select
    End If
    
    j = Sheets(Syf).Cells(Rows.Count, "A").End(3).Row + 1
    
    If Olcut Like "*ÜST" Then
        Ana.Range("A1").CurrentRegion.Offset(1, 0).Copy Sheets(Syf).Range("A" & j)
    Else
        Ana.Range("A2:Q" & i).Copy Sheets(Syf).Range("A" & j)
    End If
        
End Sub

Kod: 
Function SayfaVarYok(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarYok = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
    
End Function
 

Ekli dosyalar

Bilgi ricası

Sayın Korhan Ayhan

Günaydın.. Konu ilgimi çekti.

Kodunuzu nereye yazacağıma karar veremedim.

Yardımınızı bekliyorum.
 
Merhaba,

Sn. assenucler yanlış anlamayın ama bin küsür mesajınıza rağmen bu mesajı yazmanıza açıkçası pek anlam veremedim. Artık hangi kodu nereye yazmanız gerektiğini öğrenmiş olmanız gerekiyordu diye düşünüyorum.

Lütfen biraz araştırın. Forumda bunlarla ilgili resimli ve sözlü anlatımlar var.


assenucler' Alıntı:
Sayın Korhan Ayhan

Günaydın.. Konu ilgimi çekti.

Kodunuzu nereye yazacağıma karar veremedim.

Yardımınızı bekliyorum.
Genişletmek için tıkla ...
 
Necdet Yeşertener' Alıntı:
Merhaba,

Korhan bey yanıtlamış bende birşeyler yapmıştım, alternatif olsun.

Aşağıdaki kodlar ThisWorkbook'un kod sayfasında olmalı.

Herhangi bir sayfada, herhangi bir hücreye çift tıkladığınızda kod çalışır.
İlgili sayfada süz işlemi yaptıysanız ve ölçütünüz de "1000 TL ÜSTÜ" ise süzülen veriler ilgili sayfaya (Sayfa yoksa açılır) aktarılır, aksi halde yine aktif sayfada ilk 100 satır yine ilgili sayfaya (Sayfa Yoksa Açılır) aktarılır.
Genişletmek için tıkla ...


Necdet Bey bu şekilde çok güzel çalışıyor, ilk 100 sıra için akratmayı bu makro mükemmel ötesi yapıyor fakat 2 işleme ihtiyaç duyuyorum.

1.si "AFYON" sayfasında "Q" sütünunda "1000 TL üst" yazan satır kaç tane olursa olsun(3bin 5bin satır oluyor zaman zaman) onları süzüp Afyon 1000 TL diye yeni sekmeye yazması,
2.si de sizin vermiş olduğunuz kodun yaptığı iş.

Şöle olabilirmi mesela ilgili İL'in a1 hücresine tıkladığımız da o İL'in "Q" sütününda "1000 TL ÜST" yazanları o İL'e ait "..... 1000 TL" diye sekme açıp oraya kopyalaması, a2 hücresine tıkladığımızda da sizin İLK 100 sıra için olan kodu yapması.

Ayrıca Necdet Bey ve Korhan Bey alakanızdan ve yardımlarınızdan dolayı çok teşekkür ediyorum size ve tüm saygı değer uzman arkadaşlara.
 
Korhan Ayhan' Alıntı:
Merhaba,

Aşağıdaki kodu denermisiniz.
Genişletmek için tıkla ...


Korhan Bey şimdi de sizin vermiş olduğunuz kodu denedim buda mükemmel ayrıca Genel içinde yapmışsınız onu da gene forumdan buldum kod sayesinde yapmaya çalışacakdım ama zahmet vermişsiniz valla sölenecek kelime bulamıyorum hepinizden allah razı olsun herkes çok yardımsever taktir etmemek mümkün değil.

Herkese çok teşekkür ediyorum.
 
ccuneyt13' Alıntı:
Necdet Bey bu şekilde çok güzel çalışıyor, ilk 100 sıra için akratmayı bu makro mükemmel ötesi yapıyor fakat 2 işleme ihtiyaç duyuyorum.

1.si "AFYON" sayfasında "Q" sütünunda "1000 TL üst" yazan satır kaç tane olursa olsun(3bin 5bin satır oluyor zaman zaman) onları süzüp Afyon 1000 TL diye yeni sekmeye yazması,
2.si de sizin vermiş olduğunuz kodun yaptığı iş.

Şöle olabilirmi mesela ilgili İL'in a1 hücresine tıkladığımız da o İL'in "Q" sütününda "1000 TL ÜST" yazanları o İL'e ait "..... 1000 TL" diye sekme açıp oraya kopyalaması, a2 hücresine tıkladığımızda da sizin İLK 100 sıra için olan kodu yapması.

Ayrıca Necdet Bey ve Korhan Bey alakanızdan ve yardımlarınızdan dolayı çok teşekkür ediyorum size ve tüm saygı değer uzman arkadaşlara.
Genişletmek için tıkla ...

Merhaba,

Aslında ben soruyu tam olarak anlamadığım için süzme işini size bırakmıştım, kodlar o şekilde çalışıyor. Siz süz yaptıktan sonra kod neye göre süzüldüğünü anlayıp ilgili ilin sayfasını açıyor ve aktarıyordu.

Şimdi demek istediğinizi anladım, kodlarda değişiklik yapmak gerek ama şu an işyerinde pek boş değilim, kısa süre içinde umarım bakabilirim.

Siz tüm sayfalar için otomatik mi olsun istiyorsunuz yoksa seçtiğim sayfada bu işlemler yapılsın istiyorsunuz?
 
Necdet Yeşertener' Alıntı:
Merhaba,

Aslında ben soruyu tam olarak anlamadığım için süzme işini size bırakmıştım, kodlar o şekilde çalışıyor. Siz süz yaptıktan sonra kod neye göre süzüldüğünü anlayıp ilgili ilin sayfasını açıyor ve aktarıyordu.

Şimdi demek istediğinizi anladım, kodlarda değişiklik yapmak gerek ama şu an işyerinde pek boş değilim, kısa süre içinde umarım bakabilirim.

Siz tüm sayfalar için otomatik mi olsun istiyorsunuz yoksa seçtiğim sayfada bu işlemler yapılsın istiyorsunuz?
Genişletmek için tıkla ...

Evet Necdet Bey tüm sayfalar için istemiştim. Korhan beyin vermiş olduğu kod mesela sabit sekmelere veriyi aktarıyor, sizin kod ise ilgili sekmeyi kendisi açıyor aslında her ikiside aynı işi yapıyor ama sizinkini 1000 TL için olanı yapımıyor tek eksik o.

Fakat sizin vermiş olduğunuz kod ilgimi çekdi bir başka tablom var onun üstünde değişiklilker yapmaya çalışıcam yapabilirsem :)

Dediğim gibi Korhan beyin verdiği kodlar işimi halletti takdir sizin, siz kodlarda değişiklik yaparsanız yok ben istemem demem :) . Ama size daha fazla zahmet vermekde istemem.

Hayırlı işler dilerim.
 
Merhaba,

Aşağıdaki kodlar tüm sayfalar için değil sizin istediğiniz sayfalar için süz yapar ve aktarır. Yani yarı otamatik oldu :)

İlgili sayfada A sütununa çift tıklarsanız 1000 TL ÜST olarak süzer ve aktarır, B sütununa çift tıklarsanız ilk 100 kayıdı aktarır.

Tabi ilgili sayfalara yapar aktarmayı, sayfalar yoksa da açar.

Kodlar ThisWorkbook'un kod bölümünde olmalı.

Kod: 
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
 
    If ActiveSheet.Name Like "*1000" Then Exit Sub
    
    If Intersect(Target, [A:B]) Is Nothing Then Exit Sub
    If ActiveSheet.Name Like "*1000*" Or _
       ActiveSheet.Name Like "*İLK YÜZ" Then Exit Sub
       
    Dim Syf As String
    Dim i   As Long
    Dim j   As Long
    Dim Ana As Worksheet
    Dim Olcut As String
    
    On Error Resume Next
    Application.ScreenUpdating = False
    
    Set Ana = ActiveSheet
        
    If ActiveSheet.AutoFilterMode = True Then Selection.AutoFilter
    
    i = ActiveSheet.Cells(Rows.Count, "A").End(3).Row
    
    If Target.Column = 1 Then
        Syf = ActiveSheet.Name & " 1000"
        ActiveSheet.Range("$A$1:$Q$" & i).AutoFilter Field:=17, Criteria1:="1000 TL ÜST"
    Else
        Syf = ActiveSheet.Name & " İLK YÜZ"
        If i > 101 Then i = 101
    End If
    
    If SayfaVarYok(Syf) = False Then
        Worksheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = Syf
        Ana.Range("1:1").Copy Range("A1")
        Ana.Select
    End If
    j = Sheets(Syf).Cells(Rows.Count, "A").End(3).Row + 1
    
    If Target.Column = 1 Then
        Ana.Range("A1").CurrentRegion.Offset(1, 0).Copy Sheets(Syf).Range("A" & j)
    Else
        Ana.Range("A2:Q" & i).Copy Sheets(Syf).Range("A" & j)
    End If
    
    Sheets(Syf).Cells.EntireColumn.AutoFit
    Selection.AutoFilter
    MsgBox Syf & " SAYFASINA VERİLER AKTARILMIŞTIR....", vbInformation, "NECDET YEŞERTENER --> [URL="http://www.excel.web.tr/"]www.excel.web.tr[/URL]"
    Application.ScreenUpdating = True
    
End Sub

Kod: 
Function SayfaVarYok(SayfaAdi As String) As Boolean
    On Error Resume Next
    SayfaVarYok = CBool(Len(Worksheets(SayfaAdi).Name) > 0)
    
End Function
 

Ekli dosyalar

Necdet Yeşertener' Alıntı:
Merhaba,

Aşağıdaki kodlar tüm sayfalar için değil sizin istediğiniz sayfalar için süz yapar ve aktarır. Yani yarı otamatik oldu :)

İlgili sayfada A sütununa çift tıklarsanız 1000 TL ÜST olarak süzer ve aktarır, B sütununa çift tıklarsanız ilk 100 kayıdı aktarır.

Tabi ilgili sayfalara yapar aktarmayı, sayfalar yoksa da açar.

Kodlar ThisWorkbook'un kod bölümünde olmalı.
Genişletmek için tıkla ...

Harikasınız. Korhan Bey'in makroda Sizin makroda birbirinden güzel.

Ellerinize sağlık.
 
Merhaba,

İki değişik makronuz oldu, güle güle kullanınız. :)
 
Sayın Korhan Ayhan;

Üstadım, öncelikle verdiğiniz yanıt için teşekkürler. İlk mesaja eklenen dosyaya baktığımda 15'in üzerinde sayfa olduğunu görünce, her bir sayfaya "Aktar" düğmesine ekleme konusunda kararsız kaldığım için, yanlış bir işlem yapmama adına bu soruyu sordum.

Sanırım yazdığım açıklamada meramımı size tam olarak ifade edemedim..

İyi akşamlar.

Sevgi ve saygılar.



Sayın Necdet Yeşertener, emek ve katkılarınız için teşekkürler.

Sevgi ve saygılar.
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst