Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Makro-VBA
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Makro-VBA Makro veya VBA ile ilgili sorularınızı buraya gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 18-04-2017, 18:25   #1
Zafer GÜL
 
Giriş: 18/04/2017
Şehir: İSTANBUL
Mesaj: 4
Excel Vers. ve Dili:
Türkçe
Post Mükerrer bilgileri yeni sayfaya kopyalama

Merhaba,
Forumda daha öce açılmış olan konuları biraz inceledim ancak tam olarak ihtiyacıma cevap olacak bir makro göremedim. (Çok fazla var)
Yaklaşık 3000 satırlık bir listem var. Bu listede Sayfa1 C kolonundaki sicil numarasına göre sorgulama yaparak mükerrer olan sicillerin olduğu satırların hepsini 2.ci sayfaya taşımak istiyorum. (Satır A : DD arasıda olabilir.)

Mümkün ise aşağıdaki şekilde yapmak istiyorum.

* Makroyu çalıştırdığımda yeni sayfa açılacak, açılan sayfanın ismi Sayfa1 birinci satır C kolonundaki hücredeki metin olacak. Ör: "SİCİL"
* Sayfa1'de 1 satırda bulunan liste başlıkları Sayfa2 birinci satıra kopyalanacak.
* C Kolonunda bulunan siciller sorgulanarak birden fazla olanların bulunduğu satırlar yeni sayfaya kopyalanacak. (kaç tane ise)
* Bulunan satırlar kopyalandıktan sonra C kolonu küçükten büyüğe doğru sıralamak istiyorum.

* 2013 Türkçe versiyon kullanıyorum.

Biraz detaylı istedim çünkü benzer şekilde sorgulama yaptıracağım 5-6 kolon daha olacak. Onları sizin cevaplarınızdan faydalanarak çözmeye çalışacağım.
Saygılar,
Zafer GÜL Çevrimdışı   Alıntı Yaparak Cevapla
Eski 18-04-2017, 22:07   #2
Ömer
Moderatör
 
Ömer kullanıcısının avatarı
 
Giriş: 18/08/2007
Şehir: Kuşadası
Mesaj: 18,384
Excel Vers. ve Dili:
Excel 2010 Türkçe
Varsayılan

Merhaba,

Sorunuzu destekleyen 15-20 satırlık örnek bir çalışma hazırlayıp dosya içerisinde olmasını istediğinizide manuel hazırlayarak konuyu açıklamanızı rica ederim.

www.dosya.tc

.
__________________
.
Ömer Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-04-2017, 07:32   #3
Zafer GÜL
 
Giriş: 18/04/2017
Şehir: İSTANBUL
Mesaj: 4
Excel Vers. ve Dili:
Türkçe
Post Yanıt

Merhaba Ömer bey,

Örnek olarak istediğiniz dosyayı 19.04.2017 de gönderdim, yardımınızı bekliyorum.
Saygılar,
Zafer GÜL Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-04-2017, 09:55   #4
Ömer
Moderatör
 
Ömer kullanıcısının avatarı
 
Giriş: 18/08/2007
Şehir: Kuşadası
Mesaj: 18,384
Excel Vers. ve Dili:
Excel 2010 Türkçe
Varsayılan

Mesaj olarak bana gelmedi.

Dosyayı siteye yükledikten sonra indirme linkini burada paylaşmanızı rica ederim.

.
__________________
.
Ömer Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-04-2017, 12:39   #5
Zafer GÜL
 
Giriş: 18/04/2017
Şehir: İSTANBUL
Mesaj: 4
Excel Vers. ve Dili:
Türkçe
Varsayılan Link

Pardon, acemilik işte

http://s3.dosya.tc/server11/1p53nv/Liste.xlsx.html
Zafer GÜL Çevrimdışı   Alıntı Yaparak Cevapla
Eski 21-04-2017, 13:10   #6
Ömer
Moderatör
 
Ömer kullanıcısının avatarı
 
Giriş: 18/08/2007
Şehir: Kuşadası
Mesaj: 18,384
Excel Vers. ve Dili:
Excel 2010 Türkçe
Varsayılan

Bu şekilde deneyin.

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub Mukerrerleri_Listele()

    Dim d As Object, Ss As Worksheet, S1 As Worksheet, i As Long
    Dim deg, s, a1, sat As Long, c As Range, Adr As String
    
    Set Ss = Sheets("SİCİL")
    Set S1 = Sheets("Sayfa1")
    Set d = CreateObject("Scripting.Dictionary")
    
    Application.ScreenUpdating = False
    S1.Select
    
    For i = 2 To Cells(Rows.Count, "C").End(xlUp).Row
        deg = Cells(i, "C")
        If Not d.exists(deg) Then
            s = Array(1, Cells(i, "C"))
            d.Add deg, s
        Else
            s = d.Item(deg)
            s(0) = s(0) + 1
            d.Item(deg) = s
        End If
    Next i
    
    Ss.Select
    Range("A2:IV" & Rows.Count).Clear
      
    a1 = d.items: sat = 2
    For i = 0 To d.Count - 1
        s = a1(i)
        If s(0) > 1 Then
            With S1.[C:C]
                Set c = .Find(s(1), , xlValues, xlWhole)
                If Not c Is Nothing Then
                    Adr = c.Address
                    Do
                        S1.Rows(c.Row).Copy Cells(sat, "A")
                        Cells(sat, "A") = sat - 1
                        sat = sat + 1
                    Set c = .FindNext(c)
                    Loop While Not c Is Nothing And c.Address <> Adr
                End If
            End With
        End If
    Next i
    
    Application.ScreenUpdating = True

End Sub
.
__________________
.
Ömer Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 02:29


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Hurda - Torna - Çorlu Web Tasarım - Tarot Falı - Fenerbahçe Haberleri - Trakya Haberleri - Investing - Hurda - Kobi Danışmanlık - Tekirdağ Samsung - Kozmetik Ürünler - Sağlıklı Makyaj Ürünleri - Yaşlanma Karşıtı Ürünler - Excel Eğitimi - Çorlu OSGB - Lingerie - Dyeing Machine - Çorlu Temizlik- Didim Çatı İnşaat- Çorlu Ambar- Hava Çekimi- Hazır Site- SEO- Çorlu Estetik
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden