şartlı birleştirme

[oydemir]

Necdet beyin yapığı kodlar işimi çok görüyor kendisine teşekkür ederim.

kodlar

B kolonundaki değerler aynı ise f kolonundaki değerleri birleştirip h sütununa yazmakta.

Ama bir ekleme yapılması gerekiyor ,

Ekleme yapılması islenen ; b kolonundakiler aynı ise a kolonundaki değerlerin aynı olanlarından bir h kolonuna yazması tanesini yazması

Örnek ;b kolonunda b2=1 b2=1 b=1 b kolonunda üç tane 1 car

E kolonunda e1=a e2=a e3=b e kolonunda 2 tane a 1 tane b var

H1 kolonuna yazması gereken A B

H2 kolonuna yazması gereken A B

H3 kolonuna yazması gereken A B



Sub işlem()
Application.ScreenUpdating = False
On Error Resume Next
Range("h2:h65536").ClearContents

For i = 2 To Range("b65536").End(xlUp).Row
Cells(i, "h") = Cells(i, "b")

If Cells(i, "b") = Cells(i + 1, "b") Then
Cells(i, "h") = Cells(i, "e") & " " & Cells(i + 1, "e")
End If

Next i
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

 

[veyselemre]

Sub işlem()
    Dim son&
    Range("H2:H" & Rows.Count).ClearContents
    son = Range("B" & Rows.Count).End(xlUp).Row
    With CreateObject("Scripting.Dictionary")
        For i = 2 To son
            If Cells(i, "B").Value = Cells(i + 1, "B").Value Then
                .RemoveAll
                For ii = i To son
                    If Cells(i, "B").Value = Cells(ii, "B").Value Then
                        .Item(Cells(ii, "E").Value) = Null
                    Else
                        Exit For
                    End If
                Next ii
                Cells(i, "H").Resize(ii - i).Value = Join(.keys, " ")
                i = ii - 1
            Else
                Cells(i, "H").Value = Cells(i, "B").Value
            End If
        Next i
    End With
    MsgBox "İşlem TAMAM.", vbInformation
End Sub

 

[oydemir]

teşekkürler elinize sağlık

 

[oydemir]

veyselemre hocam
çift olmayanların (b2) h2 hücresine yazmış bunun yerine e2 hücresini h2 hücresine yazdırmak mümkün mü.
diğer tarafları tam islediğim gibi

 

[oydemir]

hocam
If Cells(i, "B").Value = Cells(i, "B").Value Then
saırdaki 1 yok ettim düzeldi umarım yanlış bişey yapmamışımdır.