grupları algıla,biçimle

[peleryn]

Herkese Merhabalar;

Sorum A sütunu boyunca süzülerek gelmiş verilerin ardışık ve benzer olanlarını birleştirilmiş bir hücrede teke indirmekle ilgili..Ayrıntılı açıklamayı ekteki örnek dosyada yaptım.

İlgilenecek olanlara çok teşekkür ederim.

 

[Orion1]

Dosyanız ektedir.

Sub bicim()
Range("D2:D65536").UnMerge
Range("D2:D65536").Clear
sat2 = Cells(65536, "A").End(xlUp).Row
deg = Range("A2").Value
sat = 2
ilk = 2
Do While sat <= sat2
    say = say + 1
    Cells(ilk, "D").Value = Cells(ilk, "A").Value
    Cells(ilk, "D").Font.Bold = True
    Cells(ilk, "D").HorizontalAlignment = xlCenter
    Cells(ilk, "D").VerticalAlignment = xlCenter
    If say Mod 2 = 0 Then
        Range("D" & ilk).Interior.Color = vbYellow
        Else
        Range("D" & ilk).Interior.Color = vbGreen
    End If
        
    Do While Cells(sat, "A").Value = deg
        sat = sat + 1
    Loop
    Range("D" & ilk & ":D" & sat - 1).Merge
    ilk = sat
    deg = Cells(sat, "A").Value
Loop
MsgBox "İşlem Tamamdır." & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[peleryn]

Evren hocam elinize sağlık yine çok sade ve gayet net problemi çözmüşsünüz çok teşekkür ederim.

Hocam kodlardaki ilk iki satırı silip kalan tüm D'leri A yaptım yerinde,verilerin bulunduğu sütunda işlem yapmak için..Orada da aynen çalışıyor fakat seçimler birden çok veri değeri içerdiği için en soldaki veriyi saklayacağına dair bir uyarı veriyor..

Makro kaydet yolu ile bunu bertaraf edecek kodu bulmayı denedim ama bulamadım.A sütunundaki verilere bulundukları yerde bu işlemi uygulayabilmem için de yardımcı olursanız çok sevinirim.

 

[Orion1]

Evren hocam elinize sağlık yine çok sade ve gayet net problemi çözmüşsünüz çok teşekkür ederim.

Hocam kodlardaki ilk iki satırı silip kalan tüm D'leri A yaptım yerinde,verilerin bulunduğu sütunda işlem yapmak için..Orada da aynen çalışıyor fakat seçimler birden çok veri değeri içerdiği için en soldaki veriyi saklayacağına dair bir uyarı veriyor..

Makro kaydet yolu ile bunu bertaraf edecek kodu bulmayı denedim ama bulamadım.A sütunundaki verilere bulundukları yerde bu işlemi uygulayabilmem için de yardımcı olursanız çok sevinirim.

Siz 2nci satırdan başlar şekilde yapmışsınız bende kodları öyle yaptım.
iLk satırı silerde ilk satırdan başlarsanız eksik çalışır.
İlk satırdan başlaması için aşağıdaki dosyayı kullanın.

Sub bicim()
Range("D1:D65536").UnMerge
Range("D1:D65536").Clear
sat2 = Cells(65536, "A").End(xlUp).Row
deg = Range("A2").Value
sat = 1
ilk = 1
Do While sat <= sat2
    say = say + 1
    Cells(ilk, "D").Value = Cells(ilk, "A").Value
    Cells(ilk, "D").Font.Bold = True
    Cells(ilk, "D").HorizontalAlignment = xlCenter
    Cells(ilk, "D").VerticalAlignment = xlCenter
    If say Mod 2 = 0 Then
        Range("D" & ilk).Interior.Color = vbYellow
        Else
        Range("D" & ilk).Interior.Color = vbGreen
    End If
        
    Do While Cells(sat, "A").Value = deg
        sat = sat + 1
    Loop
    Range("D" & ilk & ":D" & sat - 1).Merge
    ilk = sat
    deg = Cells(sat, "A").Value
Loop
MsgBox "İşlem Tamamdır." & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[peleryn]

Evren Hocam elimde olmadan sizi fazladan yormuş oldum özür dilerim.Kastettiğim ilk iki satır sizin kodlarınızın ilk iki satırı ve bahsettiğim D'ler de kodlarınızdaki D'lerdi.Dosyaya bakabilirseniz sorunumu daha net görebilirsiniz.

 

[Orion1]

Dosyanız ektedir.

Sub bicim()
Range("A2:A65536").UnMerge
'Range("D2:D65536").Clear
sat2 = Cells(65536, "A").End(xlUp).Row
deg = Range("A2").Value
sat = 2
ilk = 2
Application.DisplayAlerts = False
Do While sat <= sat2
    say = say + 1
    Cells(ilk, "A").Value = Cells(ilk, "A").Value
    Cells(ilk, "A").Font.Bold = True
    Cells(ilk, "A").HorizontalAlignment = xlCenter
    Cells(ilk, "A").VerticalAlignment = xlCenter
    If say Mod 2 = 0 Then
        Range("A" & ilk).Interior.Color = vbYellow
        Else
        Range("A" & ilk).Interior.Color = vbGreen
    End If
        
    Do While Cells(sat, "A").Value = deg
        sat = sat + 1
    Loop
    Range("A" & ilk & ":A" & sat - 1).Merge
    ilk = sat
    deg = Cells(sat, "A").Value
Loop
Application.DisplayAlerts = True
MsgBox "İşlem Tamamdır." & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[peleryn]

Evren Hocam aklınıza sabrınıza sağlık iyiki varsınız çok teşekkürler..İyi geceler dilerim

 

[Orion1]

Evren Hocam aklınıza sabrınıza sağlık iyiki varsınız çok teşekkürler..İyi geceler dilerim

Rica ederim.
İyi çalışmalar.