Koşullu Hücre Birleştirme

[yasin85]

Merhaba,

Excel dosyamda A satırlarında aynı değerler alt alta sıralı karşılığında da farklı veriler mevcut karşılığında var olan verileri bir hücre içerisinde alt alta eklemek istiyorum.

ilgili dosyayı örnek olarak ekledim zaman ayırıp bir buton ile işlemimi çöze bilecek yardımı sağlarsanız çok memnun olurum.

http://s7.dosya.tc/server11/yxjx8x/HUCRE_BIRLESTIRME.xlsx.html

 

[turist]

Dosyanız eklidir.

 

[yasin85]

Çok teşekkür ederim tam istediğim gibi olmuş. @turist

 

[turist]

Sağ olun.

 

[yasin85]

Sn. @turist Merhaba,

Yukarıda yer alan makro çalışmasını devamlı kullanıyorum şuan 400.000 satırlık bir işlem yapmam gerekli işlemi başlatalı yaklaşık 10 saat olmuştur pc açık bıraktım çalışma halen devam ediyor..

İlgili makroyu hızlandırmamız mümkün müdür?

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Verileri_Listele()
    Dim Zaman As Double, Son As Long
    Dim Liste As Variant, Dizi As Object, X As Long
    
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Range("D:E").Clear
    Range("D1:E1") = Array("No", "Ref No")
    Range("D1:E1").Font.Bold = True
    Range("D1:E1").HorizontalAlignment = xlCenter
    Range("D:D").VerticalAlignment = xlCenter
    
    Son = Cells(Rows.Count, 1).End(3).Row
    Liste = Range("A2:B" & Son).Value
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    For X = LBound(Liste, 1) To UBound(Liste, 1)
        If Not Dizi.exists(Liste(X, 1)) Then
            Dizi.Item(Liste(X, 1)) = Liste(X, 2)
        Else
            Dizi.Item(Liste(X, 1)) = Dizi.Item(Liste(X, 1)) & Chr(10) & Liste(X, 2)
        End If
    Next
    
    Range("D2").Resize(Dizi.Count, 2) = Application.Transpose(Array(Dizi.keys, Dizi.items))
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye", vbInformation
End Sub

 

[yasin85]

Sn. @Korhan Ayhan ,

Çalışmanızı denedim, Tüm çalışmayı getirmiyor 9045 adet getirdi ; 80.000 kalem gelmesi gerekirken mümkünse tekrar inceleme şansınız olur mu?

Teşekkürler..

 

[yasin85]

Sn. @Korhan Ayhan
Bir detay daha var sayfa2 veri gelmesi gerekirken sayfa1 gelen veriler geliyor bilginize.

 

[Korhan Ayhan]

Sanırım satır sayısının fazla olması Transpose fonksiyonunda problem yaratıyor.

Aşağıdaki kodu deneyiniz. Ben 1.000.000 satırda denedim. Yaklaşık 60 saniyede işlem tamamlandı.

Option Explicit

Sub Verileri_Listele()
    Dim Zaman As Double, Son As Long, Liste As Variant
    Dim Yeni_Liste As Variant, Dizi As Object
    Dim S1 As Worksheet, S2 As Worksheet, X As Long, Say As Long
    
    Zaman = Timer
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set S1 = Sheets("Sayfa1")
    Set S2 = Sheets("Sayfa2")
    
    With S2
        .Range("A:B").Clear
        .Range("A1:B1") = Array("No", "Ref No")
        .Range("A1:B1").Font.Bold = True
        .Range("A1:B1").HorizontalAlignment = xlCenter
        .Range("A:A").VerticalAlignment = xlCenter
    End With
    
    Son = S1.Cells(Rows.Count, 1).End(3).Row
    Liste = S1.Range("A2:B" & Son).Value
    Set Dizi = CreateObject("Scripting.Dictionary")
    
    ReDim Yeni_Liste(1 To UBound(Liste, 1), 1 To 2)
    
    For X = LBound(Liste, 1) To UBound(Liste, 1)
        If Not Dizi.Exists(Liste(X, 1)) Then
            Say = Say + 1
            Dizi.Add Liste(X, 1), Say
            Yeni_Liste(Say, 1) = Liste(X, 1)
            Yeni_Liste(Say, 2) = Liste(X, 2)
        Else
            Yeni_Liste(Dizi.Item(Liste(X, 1)), 2) = Yeni_Liste(Dizi.Item(Liste(X, 1)), 2) & Chr(10) & Liste(X, 2)
        End If
    Next
    
    S2.Range("A2").Resize(Dizi.Count, 2) = Yeni_Liste
    S2.Range("B:B").ColumnWidth = 100
    S2.Columns.AutoFit
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00000") & " Saniye", vbInformation
End Sub

 

[yasin85]

Sn. @Korhan Ayhan ,

Ellerinize sağlık çok teşekkür ederim tam istediğim gibi olmuş.
İnanılmaz bir iş yükünden kurtardınız size ve sizin gibi destek olan tüm arkadaşlarımızdan Allah razı olsun inanın çok güzel dualar alıyorsunuz.

 

[yasin85]

Merhaba sn. @Korhan Ayhan & sn. @turist ,

Sizlerden 2018 ve 2019 tarihlerinde destek aldığımız ve bugün dahi kullandığımız bir alanda tekrardan desteğinize ihtiyacımız var 30 binlik listeleri başarılı birşekilde yapıyor fakat 500.000 kalemlik işlemlerde işlem bittiğinde sonuç vermiyor örnekleri ekledim link olarak siteye eklyemedim boyutu büyük olduğu için yardımlarınızdan dolayı şimdiden teşekkür ederiz

bicimlendirme.rar dosyasını indir - download

bicimlendirme.rar dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[veyselemre]

Power Query;

let
    Source = Excel.CurrentWorkbook(){[Name="Tablo1"]}[Content],
    Group = Table.Group(Source, {"no"}, {{"Count", each _, type table}}),
    List = Table.AddColumn(Group, "List", each [Count][ref no]),
    Wxtract = Table.TransformColumns(List, {"List", each Text.Combine(List.Transform(_, Text.From), Character.FromNumber(10)), type text}),
    RC = Table.RemoveColumns(Wxtract,{"Count"})
in
    RC

 

[yasin85]

Sn. @veyselemre bey ,
Yardımınız için çok teşekkür ederiz.
Devamlı kullancağımız bir çalışma oldu.

Başka arkadaşlarda kullanmak isterse "no" kısmı sadece numerik olduğu için "Count" toplamaya çalışıyor bunun çözümü için başına metinsel bir karakter yani harf ekledim aşşağıdaki linkte yapılan işlemleri harfiyen yapıp koduda yazınca çok stabil bir çalışma ortaya çıktı.

Link
kullanımını izle

 

[Korhan Ayhan]

@yasin85,

Power Query ile birleştirilmiş alandaki veri uzunluğu ne kadar oluyor.

Ben önerdiğim kodu "B" sütununda daha kısa veriler ile denediğimde sonuç alabiliyorum. Ama veri uzunluğu artınca sanırım excelin kafası karışıyor.

 

[yasin85]

Sn. @Korhan Ayhan Bey,

Dediğiniz gibi kısa işlemlerde sorun yok uzun verilerde sonuç alamadık.
Şuan için pratik olan sizlerin makrosu onları halen kullanıyorum (30 bin ve 40 bin arası ) daha büyük 500 bin kalemlik verilerde "Power_Query" ile işimizi çözüldü.

Bu çalışmalar sayesinde kazandığımız zamanlar için sizlere çok teşekkür ederiz.