Alt Alta Satırları Koşullu Olarak Birleştirme

[erdalcan]

Merhaba;

B sütunundaki verilere göre, C sütununda bulunan hücreleri tek hücrede birleştirmek istiyorum. "Concatenate" ve "if" formülleri ile bu işlemi yapabiliyorum ancak C sütununda birleştirilecek hücre sayısı değişken olduğu için (bazen tek hücre, bazen 10 hücre) hücre sayısı fazla olduğunda formül çok karışıyor. Forumda benzer makrolar buldum ama makro bilgim olmadığı için kendi dosyama uyarlayama yapamadım. Bu konuda yardımınızı rica ediyorum.

Örnek dosya aşağıdaki linktedir.

https://app.box.com/s/z9i3a6wmqcjphcol38iq

 

[ÖmerBey]

Aşağıdaki kodu dener misiniz?

Sub Birleştir()
For a = 4 To [C65500].End(3).Row
    If Cells(a, "B") <> "" Then
        Set hücre = Cells(a, "C")
    ElseIf Cells(a, "C") <> "" Then
        hücre.Value = hücre.Value & " " & Cells(a, "C")
        Cells(a, "C") = Empty
    End If
Next
End Sub

 

[Ömer BARAN]

Maksatınız hücreleri mi yoksa içeriklerini mi birleştirmek?
Cep telefonundan yazıyorum, belge içeriğine bakamıyorum.

 

[erdalcan]

Sayın mucit77 yardımınız için çok teşekkür ediyorum. Verdiğiniz kodu denedim ve istediğim işlem gerçekleşti.

Bir konuda daha yardım rica ediyorum. Bu işlem sonucunda aralarda boş satırlar oluşuyor. Bunları makro ile silmek mümkün olabilir mi ?

Maksatınız hücreleri mi yoksa içeriklerini mi birleştirmek?
Cep telefonundan yazıyorum, belge içeriğine bakamıyorum.

Maksadım hücre içeriklerini birleştirmekti... mucit77'nin yardımıyla bu işlemi gerçekleştirdim.

 

[ÖmerBey]

Sayın mucit77 yardımınız için çok teşekkür ediyorum. Verdiğiniz kodu denedim ve istediğim işlem gerçekleşti.

Bir konuda daha yardım rica ediyorum. Bu işlem sonucunda aralarda boş satırlar oluşuyor. Bunları makro ile silmek mümkün olabilir mi ?

Örnek dosyanızda da olması gereken sayfasında aralarda boş satırlar mevcut, kod ona göre yazıldı.
Aralardaki boş satırları da silmek için kodu aşağıdaki şekilde değiştiriniz

Sub Birleştir()
For a = 4 To [C65500].End(3).Row
    If Cells(a, "B") <> "" Then
        Set hücre = Cells(a, "C")
    ElseIf Cells(a, "C") <> "" Then
        hücre.Value = hücre.Value & " " & Cells(a, "C")
        Cells(a, "C").EntireRow.Delete
        a = a - 1
    End If
Next
End Sub

 

[erdalcan]

Sayın mucit77 örnek dosyayı hazırlarken hata yapmışım. Önceliğim hücre içeriklerini birleştirmekti. Bu hali gerçekten çok işime yarayacak, tekrar çok teşekkür ediyorum yardımınız için...

 

[ÖmerBey]

Rica ederim, iyi çalışmalar...

 

[Jihad]

Merhaba Elimde Bir Data Mevcut Bu datada bir birleştirme yapmak istiyorum.. Şöyleki;
A Sütünundaki verileri baz alarak C ve D Sütünundaki verileri ayrı ayrı yeni hücrelerde , satırları ise aynı satırda virgül ile ayrılmış şekilde birleştirmek istiyorum
Örnek Excelimde detaylı açıklamaya çalıştım
Yardımlarınızı Rica Ederim
İyi Çalışmalar

 

[ÖmerBey]

Merhaba,
Deneyiniz...

Sub kod()
Dim s1 As Worksheet, s2 As Worksheet
Dim a As Long, sn As Long, x As Long
Dim s As Object
Dim ayr As String

Set s1 = Worksheets("Sayfa3")
Set s = CreateObject("Scripting.Dictionary")

ayr = ", "
sn = s1.Cells(Rows.Count, "A").End(3).Row
ReDim dz(1 To sn, 1 To 3)

For a = 1 To sn
    If s.exists(s1.Cells(a, "A").Value) Then
        x = s(s1.Cells(a, "A").Value)
        dz(x, 2) = dz(x, 2) & ayr & s1.Cells(a, "B")
        dz(x, 3) = dz(x, 3) & ayr & s1.Cells(a, "C")
    Else
        x = s.Count + 1
        s.Add s1.Cells(a, "A").Value, x
        dz(x, 1) = s1.Cells(a, "A")
        dz(x, 2) = s1.Cells(a, "B")
        dz(x, 3) = s1.Cells(a, "C")
    End If
Next
Set s2 = Sheets.Add(After:=s1)
s1.Range("A:C").Copy
s2.Range("A:C").PasteSpecial Paste:=xlPasteFormats
s2.Range("A:C").NumberFormat = "@"
s2.Range("A1").Resize(UBound(dz), UBound(dz, 2)).Value = dz
End Sub