yinelenen hücreleri birleştirme

[woodteacher]

E- Sutununda sırasıyla tekrar eden değerleri birleştir böl mantığında olduğu gibi tek bir hücrede birleştirmek istiyorum....satırlar kaybolmasın kaymasın..tekrar eden değerleri birleştirip kaç satırda tekrar ediyorsa , hepsini ayrı ayrı birleştirmesi...

 

[Levent Menteşoğlu]

Örnek dosyanızı eklermisiniz.

 

[Skorpiyon]

EK'li dosyayı inceleyiniz.

 

[woodteacher]

skorpiyon teşekkür ederim ilginiz için ,
Tam istediğim şey bu fakat süzme yapmasını istemiyorum,benzer değerleri alt alta zaten süzmeyle getirdim.Direk birleştirmeyi yapmak istiyorum.Birde sağda değilde olduğu yerde yapsın./SAYFA 2 yede atmasını istemiyorum diğer sayfalarda bilgi var...
Herşey için teşekkür ederim...

 

[woodteacher]

Levent Bey Örnek dosyayı eke koydum, yardımcı olabilirseniz sevinirim...

F.deki listede benzer olanların tek bir hücrede birleşmesini istiyorum..
Ayriyeten süzme yapmasını istemiyorum,süzülmüş haldeki dosyaya uygulayacağım...Diğer sayfalarada veri atmasını istemiyorum,Olduğu yerde yapsın birleşmeyi...

Şimdiden yardımcı olan arkadaşlara teşekkür ederim....

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki kodu denermisiniz.

Yalnız mesajınızdaki "süzülmüş haldeki dosyaya" ifadeniz kafamı karıştırdı. Aşağıdaki kod süzülmüş alanda sorun çıkarabilir.

Option Explicit
 
Sub AYNI_HÜCRELERİ_BİRLEŞTİR()
    Dim X As Integer, İlk As Integer
    Dim Son As Integer, Kontrol As Boolean
 
    Application.ScreenUpdating = False
    İlk = 2
 
    For X = 2 To Cells(Rows.Count, "F").End(3).Row
        If Cells(X, "F").MergeArea.Cells.Count = 0 Then
            If Cells(X, "F") = Cells(X + 1, "F") Then
                Son = X + 1
                Kontrol = True
            Else
                Kontrol = False
                On Error Resume Next
                Application.DisplayAlerts = False
                Range("F" & İlk & ":F" & Son).Merge
                İlk = Son + 1
                Application.DisplayAlerts = True
                On Error GoTo 0
            End If
        End If
    Next
 
    Application.ScreenUpdating = True
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Necdet]

Merhaba,

Kodları deneyiniz.

Sub Birlestir()
 
    Dim i           As Long, _
        j           As Long, _
        Eski_Deger  As String
 
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
 
    Eski_Deger = Range("F2")
    j = 2
 
    For i = 3 To Cells(Rows.Count, "A").End(3).Row + 1
        If Not Cells(i, "F") = Eski_Deger Then
            Eski_Deger = Cells(i, "F")
            Range("F" & j & ":F" & i - 1).Merge
            j = i
        End If
    Next i
 
    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
 
End Sub

 

[woodteacher]

Arkadaşlar hepinize çok teşekkür ederim..Çok yardımcı oldunuz......

Necdet bey sizin formülü uyguladım...Teşekkür ederim...

 

[Skorpiyon]

Rica ederiz de, sorularınızı daha net ifade ederseniz, cevaplarınızı da o şekle göre ayarlamaya çalışırız. Tekrar tekrar uğraş vermek zorunda kalmamış oluruz. Kolay gelsin.

 

[woodteacher]

Rica ederiz de, sorularınızı daha net ifade ederseniz, cevaplarınızı da o şekle göre ayarlamaya çalışırız. Tekrar tekrar uğraş vermek zorunda kalmamış oluruz. Kolay gelsin.

Kusuruma bakmayın ben yeni olduğum için forumda acemiliğime verin..
Sizin gönderdiğiniz makroyu kaydettim başka bir çalışmamda işe yaradı...
çok faydasını gördüm yardımlarınızın..
herşey için çok teşekkür ederim,

 

[munzur2400]

Merhaba,

Kodları deneyiniz.

Sub Birlestir()

    Dim i           As Long, _
        j           As Long, _
        Eski_Deger  As String

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With

    Eski_Deger = Range("F2")
    j = 2

    For i = 3 To Cells(Rows.Count, "A").End(3).Row + 1
        If Not Cells(i, "F") = Eski_Deger Then
            Eski_Deger = Cells(i, "F")
            Range("F" & j & ":F" & i - 1).Merge
            j = i
        End If
    Next i

    With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With

End Sub

bu kod çok işime yaradı çok teşekkür ederim