HÜCRELERİ BİRLEŞTİRME

[recepkutlu]

Merhaba;

Tabloda boyalı yerleri birleşmesini istiyorum. macro da olabilir.

soldaki aynı irsaliye altında olan müşterinin birden fazla satırını tek satırda birleştirsin. irsaliye tutar, m3 ve desi toplamlarını birleştirsin.

nasıl yapabilirim?

prkj2ny.JPG

excel

www.hizliresim.com

dosya yada ekran görüntüsü ekleyemedim.

teşekkürler.

 

[Necdet]

Merhaba,

Resim değil örnek dosyanızı paylaşınız v olması gerekeni de açıklayınız.

 

[recepkutlu]

Dosya nerden ekleniyor bakıyorum göremiyorum

 

[Necdet]

Dosya eklemek için Altın üye olmanız gerekir.
Paylaşım sitelerinden birine dosyanızı yükleyebilirsiniz. dosya.tc, dosya.co gibi

 

[recepkutlu]

DENEME.xlsx dosyasını indir - download

DENEME.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

evet dosyayı ekledim.

boyadığım satırları birleştirmek istiyorum kendi içinde. solundaki irsaliye bazlı olarak. sarı olanlar sabit kalacak ve yeşil olanlar toplanıp tek satıra birleştirilecek.

şimdiden teşekkürler.

 

[Korhan Ayhan]

Merhaba,

Verilerinizi yedekledikten sonra aşağıdaki kodu deneyiniz.

Option Explicit

Sub Irsaliyeleri_Birlestir()
    Dim S1 As Worksheet, Dizi As Object, Son As Long
    Dim Veri As Variant, X As Long, Say As Long
    Dim Silinecek_Alan As Range, Zaman As Double
    
    Zaman = Timer
    
    Set S1 = Sheets("TÜM LİSTE")
    Set Dizi = VBA.CreateObject("Scripting.Dictionary")
    
    Son = WorksheetFunction.Max(3, S1.Cells(S1.Rows.Count, 1).End(3).Row)
    
    Veri = S1.Range("A2:O" & Son).Value
    
    ReDim Liste(1 To UBound(Veri, 1), 1 To 4)
    
    For X = LBound(Veri, 1) To UBound(Veri, 1)
        Say = Say + 1
        If Veri(X, 1) <> "" Then
            If Not Dizi.Exists(Veri(X, 1)) Then
                Dizi.Add Veri(X, 1), Say
                Liste(Say, 1) = Veri(X, 12)
                Liste(Say, 2) = Veri(X, 13)
                Liste(Say, 3) = Veri(X, 14)
                Liste(Say, 4) = Veri(X, 15)
            Else
                Liste(Dizi.Item(Veri(X, 1)), 1) = Liste(Dizi.Item(Veri(X, 1)), 1) + Veri(X, 12)
                Liste(Dizi.Item(Veri(X, 1)), 2) = Liste(Dizi.Item(Veri(X, 1)), 2) + Veri(X, 13)
                Liste(Dizi.Item(Veri(X, 1)), 3) = Liste(Dizi.Item(Veri(X, 1)), 3) + Veri(X, 14)
                Liste(Dizi.Item(Veri(X, 1)), 4) = Liste(Dizi.Item(Veri(X, 1)), 4) + Veri(X, 15)
                If Silinecek_Alan Is Nothing Then
                    Set Silinecek_Alan = S1.Range("A" & X + 1 & ":O" & X + 1)
                Else
                    Set Silinecek_Alan = Application.Union(Silinecek_Alan, S1.Range("A" & X + 1 & ":O" & X + 1))
                End If
            End If
        End If
    Next
    
    If Say > 0 Then
        S1.Range("L2:O" & S1.Rows.Count).ClearContents
        S1.Range("L2").Resize(Say, 4) = Liste
        If Not Silinecek_Alan Is Nothing Then Silinecek_Alan.Delete xlUp
        If Say < 11 Then
            With S1.Range("A2:O12")
                .Borders.LineStyle = 1
                .Borders.Color = 10526880
                .Borders(xlEdgeBottom).ThemeColor = 5
                .Borders(xlEdgeBottom).LineStyle = 1
                .Borders(xlEdgeBottom).TintAndShade = 0.399945066682943
                .Borders(xlEdgeBottom).Weight = xlThick
            End With
        End If
        MsgBox "İşleminiz tamamlanmıştır." & vbCrLf & vbCrLf & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye"
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If

    Set S1 = Nothing
    Set Dizi = Nothing
End Sub

 

[recepkutlu]

teşekkürler.

çalıştırdım ve kendi grubunda en üst satıra topladı hepsini harika.

peki kalanları silebilir miyiz? satırı komple yada satır içeriklerini?

 

[Korhan Ayhan]

Üstte ki mesajımda ki kodu revize ettim. Tekrar deneyiniz.

 

[recepkutlu]

işlemler oldu tam da istediğim gibi çok teşekkürler.

DENEME.xlsx dosyasını indir - download

DENEME.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s7.dosya.tc

tekrar bir dosya paylaştım. burada sağ taraftaki mavi boyalı bloğu korumak için altı çizili alana kadar satırları boş ta olsa tutmak gerekiyor.

makro yaparken sol kırmızı ile boyadığım boşluklara otomatik tire koydurdum ki makro çalışırken veri görüp orayı dolu saysın istedim.

yaptığınız birleştirme makrosunu çalıştırınca o boşluklar yukarıya kaydığı için otomatik koyduğum tireler gidiyor.

mavi çizginin üstündeki boşluklar için minimum o seviyeyi nasıl kopyala diyebilirim?

teşekkürler.

 

[Korhan Ayhan]

Silme işlemi sadece A-O sütun aralığında yapılıyor. Bu sebeple mavi tablonuzun bozulma durumu olmaması gerekiyor.

 

[recepkutlu]

Sütun aralığında sorun yok.

12. satıra kadar blok halinde kalması lazım.

yani 3 satır dolu olsa bile 12. satıra kadar alanı boş bırakması lazım ki Q-S arasındaki tablonun 12. satırına kadar kalması lazım.

Anlatabildim mi?

 

[recepkutlu]

soldaki tireleri boşluk olsun diye makroda atıyorum ben. üzerine bilgi yazılınca boşluk bıraktırıyorum.

fakat birleştirme sonrası satır silip yukarıya kaydırma olunca tireler yukarıya kayıyor. bu durumda sağdaki tablomun alttan satırlar gidiyor.

şöyle birşey yapabilir miyiz?

ben makro yapamadım. başta tireler var. sizin formülle satırlar silindiğinde kalan boşluklara yine tire koysun.

yada koşullu biçimlendirme yapamadım. yani satırda veri yoksa tire koysun diye

 

[recepkutlu]

Farklı varyasyonlar denedim beceremedim.

Desteğinize ihtiyacım var teşekkürler.

 

[Korhan Ayhan]

Önerdiğim kodu revize ettim. Tekrar deneyiniz.

 

[recepkutlu]

teşekkürler. istediğim oldu.

emeğinize sağlık.