şartlı veri birleştir

[oydemir]

İyi günler Veysel Hocamın Yazdığı Kodları fazlaca kullanıyorum.
Sorunum 8000 satır olunca 20 Dakka sürüyor.
Bu işlemi birkaç kolon için yapınca süre saat oluyor.
Daha hızlı yapma şansım olabilir mi bu konuda yardım rica ediyorum.



Sub BİRLESTİRBU ()
Sheets("istatislik").Select
Range("bU2:bU" & Rows.Count).ClearContents
son = Range("c" & Rows.Count).End(xlUp).Row
With CreateObject("Scripting.Dictionary")
For i = 2 To son
If Cells(i, "c").Value = Cells(i, "c").Value Then
.RemoveAll
For ii = i To son
If Cells(i, "c").Value = Cells(ii, "c").Value Then
.Item(Cells(ii, "BN").Value) = Null
Else
Exit For
End If
Next ii
Cells(i, "bU").Resize(ii - i).Value = Join(.keys)
i = ii - 1
Else
Cells(i, "bU").Value = Cells(i, "BN").Value
End If
Next i
End With
End Sub

 

[Muzaffer Ali]

Merhaba.
Kodları değil de tam olarak ne yapmak istediğinizi örnek bir dosya ile sorarsanız çok daha hızlı ve net yanıt alırsınız.

 

[oydemir]

Veysel Hocam ilk önce İlginiz için teşekkür ederim.

C Kolonundaki aynı isimdeki kişilerin karşısındaki H Kolonuna birleştirip BS kolonuna yazıyor.

Aynı Şekilde diğer kolanlara (C kolonundaki Aynı olan değerlerin karşındaki BN kolonundaki değerleri birleştirip BT kolonuna Yazdırıyorum.

Bunda hiçbir sorun yok.

Fakat satır sayısı 10000 den fazla olunca ve ad soyadı baba adı konusu kolonundaki değerler uzun olunca ve çeşit artınca süre uzuyor. Bu konuda

Teşekkürler

 

[Muzaffer Ali]

Kodların en üst satırına Application.ScreenUpdating = False en son satırına da Application.ScreenUpdating = True satırlarını ekleyin.

200.000 satır veride denedim 30 saniye sürüyor.

 

[oydemir]

Hocam elinize sağlık teşekkürler hata herhalde bende kullandığım dosyada 30 sayfa var örnek yapmak için sayfaları silince baya bi hızlandı.

Sizin önerinizi denemek isterim.

Ekran kaydı olarak ekledim.

Verdiğiniz öneriyi doğru yapmış mıyım bilemedim sormak isterim

 

[Muzaffer Ali]

En üst ve en son satıra eklemelisiniz.

Sub BİRLESTİRparselBazlımalik()
    Application.ScreenUpdating = False
    Sheets("mizan_istatislik").Select
    Range("bs2:bs" & Rows.Count).ClearContents
        son = Range("c" & Rows.Count).End(xlUp).Row
        With CreateObject("Scripting.Dictionary")
            For i = 2 To son
                If Cells(i, "c").Value = Cells(i, "c").Value Then
                    .RemoveAll
                    For ii = i To son
                        If Cells(i, "c").Value = Cells(ii, "c").Value Then
                            .Item(Cells(ii, "BR").Value) = Null
                        Else
                            Exit For
                        End If
                    Next ii
                    Cells(i, "bS").Resize(ii - i).Value = Join(.keys)
                    i = ii - 1
                Else
                    Cells(i, "bS").Value = Cells(i, "BR").Value
                End If
            Next i
        End With
    Application.ScreenUpdating = True
End Sub

 

[oydemir]

elinize emiğinize sağlık teşekkürler idare edecek seviyeye geldi