Aynı malzeme no'larına tek nuamara vermek

[pristineli45]

Sevgili excel dostları.
Buraya ilk kez soru yolluyorum. Sorum şu:
Ekte gönderdiğim dosyanın "Sayfa1" sayfasındaki bilgileri form aracılığı ile giriyorum. İsteğimi "olması gereken" sayfasında anlattım.Aynı malzeme no ve malzeme adlarını birleştirmek istiyorum.Şimdiden teşekkürler

 

[pristineli45]

Yardımlarınızı bekliyorum excel dostları

 

[pristineli45]

Güncellemek istedim

 

[pristineli45]

İlk yazdığım mesaj galiba son mesajım olacak. Yine de umudumu kaybetmeyeyim ve son bir kez daha sorumu güncelleyeyim dedim.

 

[pristineli45]

Bugün tatil günü.Soruma bakabilecek biraz daha fazla arkadaş olabilir diye son bir umutla güncellemek istedim.

 

[tahsinanarat]

Modüle aşağıdaki kodları yapıştırarak 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
        With Range("B" & BUL.Row & ":B" & 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

 

[pristineli45]

Arkadaşım çok teşekkür ederim. İşimi gördü. Tam istediğim gibi.