Aynı numaralı farklı içerikli hücreleri birleştirmek

[use2000]

Merhabalar;

Yapmak istediğimi kısaca şöyle özetleyeyim:

a sutunu b sutunu
321123 SIYAH
321123 MAVI
321123 BEYAZ
321123 KIRMIZI


Yinelenen kod sadece bir tane olsun ( Hücreleri birleştir ve ortala ) kodun karşısında olan hücreler aynı kalsın. Ekte bulunan dosyada yapmak istediğimin manuel olarak yapılmışı mevcut. Bu konuda bana yardımcı olursanız çok sevinirim.

 

[Korhan Ayhan]

Selamlar,

İstediğiniz işlemi özet tablo ile rahatlıkla yapabilirsiniz. Forumda örnekler mevcut. Ararsanız ulaşabilirsiniz.

 

[uzmanamele]

merhaba

aşağıdaki linkte syn veyselemre'nin çalışmasını inceleyiniz.
tık tık tık...

 

[use2000]

Selamlar,

İstediğiniz işlemi özet tablo ile rahatlıkla yapabilirsiniz. Forumda örnekler mevcut. Ararsanız ulaşabilirsiniz.

Merhaba;

özet işlem tablosu ile hücre birleştirme olmuyor sanırım. Örnek olarak yapabilirseniz sevinirim. Teşekkürler..

 

[use2000]

merhaba

aşağıdaki linkte syn veyselemre'nin çalışmasını inceleyiniz.
tık tık tık...

Verdiğiniz linki inceledim ama benim durumum biraz daha spesifik galiba. Örnek dosyayı inceleyebilirseniz ve çözüm bulabilirseniz sevinirim. Yardımlarınız için çok teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

VERİ-ÖZET TABLO menüsünden inceleyebilirsiniz.

 

[use2000]

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

VERİ-ÖZET TABLO menüsünden inceleyebilirsiniz.

Evet bunda biraz yaklaştık ama numara olan sütunlar birleşik olmalı. Bu 5000 satırlık bir veride bunları tek tek birleştirmek oldukça zaman alıcı olur. Vermiş olduğunuz ekteki örnekte numaralı olan kısım birleşik olsa hiç bir sorun kalmayacak ona bir çare bulabilir miyiz? Yardımlarınız için çok teşekkür ederim.

 

[Korhan Ayhan]

Selamlar,

Özet tabloda istediğiniz tarzda çok fazla biçimlendirme yapma şansımız yok. Bunun yerine aşağıdaki kodu deneyiniz.

Option Explicit
 
Sub BİRLEŞTİR()
    Dim X As Long, BUL As Range, SAY As Long
    
    Columns("IV:IV").Delete
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("IV1"), Unique:=True
    
    For X = 2 To Range("IV65536").End(3).Row
        Set BUL = Range("A:A").Find(Cells(X, "IV"), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        SAY = WorksheetFunction.CountIf(Range("A:A"), Cells(X, "IV"))
        If SAY > 1 Then
        
        With Range("A" & BUL.Row & ":A" & BUL.Row + SAY - 1)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
             Application.DisplayAlerts = False
            .MergeCells = True
             Application.DisplayAlerts = True
        End With
        
        End If
        End If
    Next
    
    Columns("IV:IV").Delete
    
    Set BUL = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[use2000]

Selamlar,

Özet tabloda istediğiniz tarzda çok fazla biçimlendirme yapma şansımız yok. Bunun yerine aşağıdaki kodu deneyiniz.

Option Explicit
 
Sub BİRLEŞTİR()
    Dim X As Long, BUL As Range, SAY As Long
    
    Columns("IV:IV").Delete
    Columns("A:A").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("IV1"), Unique:=True
    
    For X = 2 To Range("IV65536").End(3).Row
        Set BUL = Range("A:A").Find(Cells(X, "IV"), LookAt:=xlWhole)
        If Not BUL Is Nothing Then
        SAY = WorksheetFunction.CountIf(Range("A:A"), Cells(X, "IV"))
        If SAY > 1 Then
        
        With Range("A" & BUL.Row & ":A" & BUL.Row + SAY - 1)
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
             Application.DisplayAlerts = False
            .MergeCells = True
             Application.DisplayAlerts = True
        End With
        
        End If
        End If
    Next
    
    Columns("IV:IV").Delete
    
    Set BUL = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

Teşekkür ederim. Biraz üzerinde çalışırsam bu bilgilerle istediğim tabloyu oluşturacağım sanırım. Çok teşekkürler..