Soru satırlarda tekrarlanan verileri tek hücrede birleştirmek

[SATYON]

Merhaba,
stoklarımın hangi yazıcılar ile uyumlu olduğunu listelediğim bir excel dosyam var. bu listede stok kodları tekrarlanıyor karşısında ise her bir yazıcının orjinal parça numarası ve modellerini içeren uyumluluk bilgileri yazıyor. ben her bir stok kodu için tüm uyumlulukları içeren yalnızca 1 satır olsun istiyorum. yani ayrı satırlardaki uyumlulukları tek bir hücrede birleştirmek istiyorum. konuyla ilgili yardımlarınızı rica ederim. şimdiden teşekkürler. örnek dosyaya ekteki linkten ulaşabilirsiniz. https://we.tl/t-DNYp77WJ6s

 

[çıtır]

Sorunuzu örnek excel dosyası ekleyerek sorarsanız,daha kısa sürede doğru cevaplar alabilirsiniz. Örnek excel dosyası ekleme hakkında bilgi edinmek isterseniz: https://www.excel.web.tr/threads/soru-ile-ilgili-oernek-excel-dosyasi-ekleme.174755/...

 

[SATYON]

Sorunuzu örnek excel dosyası ekleyerek sorarsanız,daha kısa sürede doğru cevaplar alabilirsiniz. Örnek excel dosyası ekleme hakkında bilgi edinmek isterseniz: https://www.excel.web.tr/threads/soru-ile-ilgili-oernek-excel-dosyasi-ekleme.174755/...

Teşekkür ederim.

 

[çıtır]

Rica ederim.Aşağıdaki kodu bir deneyiniz.

Sub Duzenleme()
Dim s1 As Worksheet
Dim lıste As Variant
Dim say As Long
Dim sd As Object
Dim son As Long
Set s1 = Sheets("Sayfa1")
 Zaman = Timer
son = s1.Cells(10000, "A").End(3).Row
Set lıste = s1.Range("A1:B" & son)
 ReDim b(1 To son, 1 To 2)
Set sd = CreateObject("Scripting.Dictionary")

For i = 1 To son
Key = lıste(i, 1)
Item = lıste(i, 2)
If Key <> "" Then

If Not sd.Exists(Key) Then
    say = say + 1
    b(say, 1) = Key
     b(say, 2) = Trim(Item)
    sd.Add Key, say
        Else
   say = sd(Key)
    If InStr(1, b(say, 2), Item, vbTextCompare) = 0 Then
    b(say, 2) = b(say, 2) & "," & Item
   
        End If
    End If
End If
Next i
s1.Range("D1").Resize(sd.Count, 2) = b

 MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

 

[YUSUF44]

Alternatif:

Sub tonerler()
Zaman = Timer
son = Cells(Rows.Count, "A").End(3).Row
[D:E].ClearContents
[D1] = "Stok Kodu"
[E1] = "Uyumlu Yazıcı Modelleri"


For i = 1 To son
    If WorksheetFunction.CountIf(Range("A1:A" & i), Cells(i, "A")) = 1 Then
        yeni = Cells(Rows.Count, "D").End(3).Row + 1
        Cells(yeni, "D") = Cells(i, "A")
        Cells(yeni, "E") = Cells(i, "B")
    Else
        sat = WorksheetFunction.Match(Cells(i, "A"), Range("D1:D" & son), 0)
        Cells(sat, "E") = Cells(sat, "E") & Chr(10) & Cells(i, "B")
    End If
Next
    Columns("D:D").ColumnWidth = 11
    Columns("E:E").ColumnWidth = 50
    With Range("E1:E" & son)
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With [D1:E1]
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Font.Bold = True
    End With
    Rows("1:" & son).EntireRow.AutoFit
    With Range("D1:D" & son)
        .NumberFormat = [A1].NumberFormat
        .HorizontalAlignment = xlCenter
    End With
End Sub

 

[SATYON]

oldu çok teşekkür ederim.

 

[SATYON]

Alternatif:

Sub tonerler()
Zaman = Timer
son = Cells(Rows.Count, "A").End(3).Row
[D:E].ClearContents
[D1] = "Stok Kodu"
[E1] = "Uyumlu Yazıcı Modelleri"


For i = 1 To son
    If WorksheetFunction.CountIf(Range("A1:A" & i), Cells(i, "A")) = 1 Then
        yeni = Cells(Rows.Count, "D").End(3).Row + 1
        Cells(yeni, "D") = Cells(i, "A")
        Cells(yeni, "E") = Cells(i, "B")
    Else
        sat = WorksheetFunction.Match(Cells(i, "A"), Range("D1:D" & son), 0)
        Cells(sat, "E") = Cells(sat, "E") & Chr(10) & Cells(i, "B")
    End If
Next
    Columns("D:D").ColumnWidth = 11
    Columns("E:E").ColumnWidth = 50
    With Range("E1:E" & son)
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    With [D1:E1]
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
        .Font.Bold = True
    End With
    Rows("1:" & son).EntireRow.AutoFit
    With Range("D1:D" & son)
        .NumberFormat = [A1].NumberFormat
        .HorizontalAlignment = xlCenter
    End With
End Sub

teşekkür ederim. oldu.

 

[SATYON]

Rica ederim.Aşağıdaki kodu bir deneyiniz.

Sub Duzenleme()
Dim s1 As Worksheet
Dim lıste As Variant
Dim say As Long
Dim sd As Object
Dim son As Long
Set s1 = Sheets("Sayfa1")
Zaman = Timer
son = s1.Cells(10000, "A").End(3).Row
Set lıste = s1.Range("A1:B" & son)
ReDim b(1 To son, 1 To 2)
Set sd = CreateObject("Scripting.Dictionary")

For i = 1 To son
Key = lıste(i, 1)
Item = lıste(i, 2)
If Key <> "" Then

If Not sd.Exists(Key) Then
    say = say + 1
    b(say, 1) = Key
     b(say, 2) = Trim(Item)
    sd.Add Key, say
        Else
   say = sd(Key)
    If InStr(1, b(say, 2), Item, vbTextCompare) = 0 Then
    b(say, 2) = b(say, 2) & "," & Item
  
        End If
    End If
End If
Next i
s1.Range("D1").Resize(sd.Count, 2) = b

MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

teşekkür ederim. çalıştı.