koşula göre hücreleri birleştirme

[hakanatalay]

ilk sütundaki değerler aynı ise, 2. sütundaki değerleri yan yana birleştirmek ve her satırda tekrarlamak istiyorum. örneği ekteki dosyada mevcut. yardımcı olursanız sevinirim.

 

[Necdet]

Merhaba,
Dosyanızı ekleyememişsiniz.

 

[hakanatalay]

Yükledim sanıyordum. Pardon.

 

[Necdet]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sonucu E sütunundan itibaren verir.
Silme vs gibi işlemleri yaptırmadım, siz kodları kendinize göre düzenleyiniz.
İlk aklıma gelen çözümü sundum. İçimdeki ses daha iyi bir çözümü var diyor

Sub Duzenle()

    Dim i   As Long, _
        c   As Range, _
        adr As String, _
        sd  As Object, _
        key As Variant, _
        itm As Variant, _
        s   As Variant

    Set sd = CreateObject("Scripting.Dictionary")
   
    For i = 6 To Cells(Rows.Count, "A").End(3).Row
        s = Cells(i, "A")
        If Not sd.exists(s) Then
            sd.Add s, Round(Cells(i, "B"), 0)
        Else
            sd.Item(s) = sd.Item(s) & "-" & Round(Cells(i, "B"), 0)
        End If
    Next i
       
    key = sd.keys
    itm = sd.items
   
    For i = 0 To UBound(key)
       
        With Range("A:A")
            Set c = .Find(key(i), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                adr = c.Address
                Do
                    Range("E" & c.Row) = c.Value
                    Range("F" & c.Row) = itm(i)
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> adr
            End If
        End With
       
    Next i
   
End Sub

 

[hakanatalay]

Merhaba,

Aşağıdaki kodları bir modüle kopyalayıp deneyiniz.

Sonucu E sütunundan itibaren verir.
Silme vs gibi işlemleri yaptırmadım, siz kodları kendinize göre düzenleyiniz.
İlk aklıma gelen çözümü sundum. İçimdeki ses daha iyi bir çözümü var diyor

Sub Duzenle()

    Dim i   As Long, _
        c   As Range, _
        adr As String, _
        sd  As Object, _
        key As Variant, _
        itm As Variant, _
        s   As Variant

    Set sd = CreateObject("Scripting.Dictionary")
  
    For i = 6 To Cells(Rows.Count, "A").End(3).Row
        s = Cells(i, "A")
        If Not sd.exists(s) Then
            sd.Add s, Round(Cells(i, "B"), 0)
        Else
            sd.Item(s) = sd.Item(s) & "-" & Round(Cells(i, "B"), 0)
        End If
    Next i
      
    key = sd.keys
    itm = sd.items
  
    For i = 0 To UBound(key)
      
        With Range("A:A")
            Set c = .Find(key(i), LookIn:=xlValues, LookAt:=xlWhole)
            If Not c Is Nothing Then
                adr = c.Address
                Do
                    Range("E" & c.Row) = c.Value
                    Range("F" & c.Row) = itm(i)
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> adr
            End If
        End With
      
    Next i
  
End Sub

tam olarak olması gerektiği gibi olmuş. Elinize sağlık Necdet Bey. Çok teşekkür ederim.