dataları kaybetmeden hücre birleştirme

[tahsinanarat]

Ekli dosyamda, siteden kopyalanmak suretiyle alınmış ve excel dosyasına yapıştırılmış datalarım mevcut,
a,b,c ve d sutunlarında satırlar birleştirilmiş olarak görünmekte,
e ve f sutunundaki dataların kaybolmaksızın birleştirilmiş satır kadar
hücre birleştirilmesini kodlarla yapmak istiyorum,
yardımcı olacak arkadaşlarıma şimdiden teşekkür ederim.
Saygılarımla

 

[omerceri]

Aşağıdaki makro E sütunundaki bilgileri L sütununda, F sütunudaki bilgileri M sütunda birleştiriyor.
Sub birles()
For i = 1 To [A65536].End(3).Row
If Range("A" & i) <> "" Then
say = Range("A" & i).MergeArea.Count
For e = i To (i + say) - 1
bir1 = bir1 & " " & Range("E" & e)
bir2 = bir2 & " " & Range("F" & e)
Range("L" & i).Value = Trim(bir1)
Range("M" & i).Value = Trim(bir2)
Next
bir1 = ""
bir2 = ""
End If

Next

End Sub

 

[tahsinanarat]

Say&#305;n omerceri karde&#351;im, eline koluna sa&#287;l&#305;k, bana &#231;ok yard&#305;mc&#305; oldunuz, te&#351;ekk&#252;r ediyorum, hay&#305;rl&#305; bayramlar diler, sayg&#305;lar sunar&#305;m. tahsinanarat

 

[tahsinanarat]

Sn. omerceri, Birle&#351;tirilen sat&#305;rlar&#305;n oldu&#287;u gibi kalmas&#305; i&#231;in, yani ayn&#305; h&#252;cre i&#231;erisinde orjinalinde g&#246;r&#252;nd&#252;&#287;&#252; gibi bir alt sat&#305;ra alabilmek i&#231;in nas&#305;l bir ilave yapabiliriz

 

[tahsinanarat]

Sn. omerceri, cevab&#305; buldum, te&#351;ekk&#252;rler.
Sub birles()
For i = 1 To [A65536].End(3).Row
If Range("A" & i) <> "" Then
say = Range("A" & i).MergeArea.Count
For e = i To (i + say) - 1
bir1 = bir1 & Chr(10) & "" & Range("E" & e)
bir2 = bir2 & Chr(10) & "" & Range("F" & e)
Range("L" & i).Value = Trim(bir1)
Range("M" & i).Value = Trim(bir2)
Next
bir1 = ""
bir2 = ""
End If
Next
End Sub

 

[Necdet]

Birden fazla hücreyi tek hücrede birleştirme

Merhaba, İyi Bayramlar,

Bende üzerinde çalışmıştım bu konunun. Boşa gitmesin ekleyim kodları.

E ve F hücrelerini aynı hücre içinde birleştiriyor, birleştirilmiş hücreleri açıyor ve açığa çıkan boş satırları siliyor.

Kodları denemeden önce dosyanın bir örneğini çıkartınız.

Sub Satir_Birlestir()
Application.ScreenUpdating = False
For i = 1 To [A65536].End(3).Row + 10
    J = Cells(i, "A").MergeArea.Count
    If J > 1 Then
        For k = 1 To J - 1
            Cells(i, "E") = [B]Trim[/B](Cells(i, "E") & [B]Chr(10)[/B] & Cells(i + k, "E"))
            Cells(i, "F") = [B]Trim[/B](Cells(i, "F") & [B]Chr(10)[/B] & Cells(i + k, "F"))
        Next k
        i = i + J - 1
    End If
Next i
    Columns("A:K").UnMerge
    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    Range("A1").Select
End Sub

 

[tahsinanarat]

Sn. Necdet_Yesertener, elinize sa&#287;l&#305;k, ger&#231;ekten &#231;ok g&#252;zel olmu&#351;, bende biraz &#246;nce birle&#351;tirilmi&#351; h&#252;crelerin orjinal sat&#305;rlar&#305;n&#305;, birle&#351;tirilmi&#351; h&#252;cre i&#231;erisine alt enter ile alt alta almaya &#231;al&#305;&#351;&#305;yordum, sizin kodlar&#305;n&#305;za nas&#305;l bir ilave yap&#305;labilinir ki, sat&#305;rlar birle&#351;tirildikten sonra arka arkaya de&#287;ide alt alta g&#246;r&#252;ns&#252;nler. Yard&#305;mlar&#305;n&#305;z i&#231;in &#231;ok te&#351;ekk&#252;r ediyorum. Sayg&#305;lar.

 

[Necdet]

Merhaba Say&#305;n tahsinanarat,

Akl&#305;ma gelmedi de&#287;il ilgili kodu bulursam o &#351;ekle &#231;evireyim. Daha &#246;nce yine bu forumda sat&#305;r a&#231;an kodu kald&#305;ran kodlar&#305; vermi&#351;tim, &#351;imdi an&#305;msam&#305;yorum, aray&#305;m bulay&#305;m ve yapay&#305;m

 

[tahsinanarat]

hatta m&#252;mk&#252;n ise son birle&#351;tirmeden sonraki bo&#351;luklar da silinebilirse &#231;ok daha iyi olacak, ilginize &#231;ok te&#351;ekk&#252;r ederim hocam.

 

[Necdet]

Merhaba,

Kodlar&#305; g&#252;ncelledim. Deneyebilir misiniz?

 

[tahsinanarat]

i&#351;te bu, ger&#231;ekten harika oldu, excel web tr'yi ve sizleri &#231;ok seviyorum arkada&#351;lar, sn. omerceri ve Sn. Necdet_Yesertener arkada&#351;lar&#305;ma &#231;ok ama &#231;ok te&#351;ekk&#252;r ediyorum. Sa&#287;olun varolun

 

[shamel]

merhabalar
sanırım VB scripti kullanamadım! bende C1 ve D1 hücrelerindeki kelimeleri A1'de alt alta birleştirmeye çalışıyorum fakat bir türlü başaramadım. örnek: =C1&" "&D1 yaptığımda iki hücrenin metinlerini tek satır haline geliyor bu satırı sanki Alt+Enter'la bölünmüş gibi basit bir formülde yapabilirmiyim?

 

[tahsinanarat]

Dosyayı yerine koydum

Evvelce sorduğum bir sorunun dosyası yerinde yoktu, çözümlenmiş dosyayı yerine koyayım istedim, hemde bu konu üzerine yeni bor soru sormak istedim.
Sorun şu, A sutununda birleştirilmiş hücrelerde E ve F sutunlarının veri kaybı olmadın birleştirebilioruz, peki A sutununda satırlar birleştirilmemiş olan satırlarda veri kaybı olmaksızın birleştirme yapmak isteseydik nasıl kodda nasıl bir değişiklik yapmamız gerekirdi. Cevap için şimdiden teşekkürler.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub BİRLEŞTİR()
    Dim X As Long, Y As Integer, İLK As Long, SON As Long, SOND As Long, SONE As Long
    
    Application.ScreenUpdating = False
        
    For X = 2 To Cells(Rows.Count, "A").End(3).Row
        If Cells(X + 1, 2) = "" Then
            İLK = X + 1
            If Cells(X, 2).End(xlDown).Row = Rows.Count Then
                SOND = Cells(Rows.Count, "D").End(3).Row
                SONE = Cells(Rows.Count, "E").End(3).Row
                SON = WorksheetFunction.Max(SOND, SONE)
            Else
                SON = Cells(X, "B").End(4).Row - 1
            End If
            
            For Y = İLK To SON
                If Cells(X, "D") = "" Then
                    Cells(X, "D") = Cells(Y, "D")
                Else
                    Cells(X, "D") = Cells(X, "D") & Chr(10) & Cells(Y, "D")
                End If
                
                If Cells(X, "E") = "" Then
                    Cells(X, "E") = Cells(Y, "E")
                Else
                    Cells(X, "E") = Cells(X, "E") & Chr(10) & Cells(Y, "E")
                End If
            Next
            
            X = SON
        End If
    Next
 
    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
 
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub