Grup olanları bulmak ,renklendirmek ve saymak.

[daali]

Selamlar,
Grup olarak birtakım metin ve sayı içerikli değerlerimi ,A ve B sutunlarında arattırıp grup olarak bulmak, renklendirmek ayrıca toplam sayısını buldurmak istiyorum.Bunu yapabilirmiyiz acaba?Yardımlarınızı bekliyorum.Şimdiden teşekkürler ediyorum.
Saygılarımla.

 

[Orion1]

Merhaba.
Ekli dosyayı inceleyiniz.
Yalnız B sütunundaki değerler sayısal değil onları toplayamıyor.
Grupla butonuna basıyorsunuz.İşlem tamam.

Sub grupla()
Dim i As Long, k As Byte, topla As Double, sonsata As Long, sonsatb As Long
Sheets("Sayfa1").Select
sonsata = Cells(65536, "A").End(xlUp).Row
Range("A1:B" & sonsata).Interior.ColorIndex = xlNone
For i = 1 To sonsata
    If Cells(i, "A").Value = Range("E1").Value Then
        For k = 1 To 4
            If Cells(i + k, "A").Value <> Cells(k + 1, "E").Value Then GoTo atla
        Next
        Cells(i, "A").Interior.ColorIndex = 6
        topla = topla + Cells(i, "A").Value
        For k = 1 To 4
            Cells(i + k, "A").Interior.ColorIndex = 6
            topla = topla + Cells(i + k, "A").Value
        Next
        i = i + 4
    End If
atla:
Next i
Range("C1").Value = topla * 1
Range("C1").NumberFormat = "#,##0.00"
sonsatb = Cells(65536, "B").End(xlUp).Row
topla = 0
For i = 1 To sonsatb
    If Cells(i, "B").Value = Range("F1").Value Then
        For k = 1 To 4
            If Cells(i + k, "B").Value <> Cells(k + 1, "F").Value Then GoTo atla2
        Next
        Cells(i, "B").Interior.ColorIndex = 8
        If IsNumeric(Cells(i, "B").Value) Then
            topla = topla + Cells(i, "B").Value
        End If
        For k = 1 To 4
        If IsNumeric(Cells(i + k, "B").Value) Then
             topla = topla + Cells(i + k, "B").Value
        End If
        Cells(i + k, "B").Interior.ColorIndex = 8
        Next
        i = i + 4
    End If
atla2:
Next i
Range("D1").Value = topla * 1
Range("D1").NumberFormat = "#,##0.00"
MsgBox "GRUPLAMA TAMAMLANDI", vbOKOnly, Application.UserName
End Sub

 

[arol11]

sayın Sezar,
Bunun gibi benzer uygulamalr için benimde işim olmakta,izninizle şu sorumu eklemek istiyorum.Grupların toplamını değilde ,bu 1.gruptan A sutununda kaç tane var? ve 2.gruptan A sutununda kaç tane var ?
gruptan kaç tane var?Bunları nasıl hesap edebiliriz?
İyi hafta sonu dileğimle ,iyi çalışmalar dilerim.

 

[Orion1]

sayın Sezar,
Bunun gibi benzer uygulamalr için benimde işim olmakta,izninizle şu sorumu eklemek istiyorum.Grupların toplamını değilde ,bu 1.gruptan A sutununda kaç tane var? ve 2.gruptan A sutununda kaç tane var ?
gruptan kaç tane var?Bunları nasıl hesap edebiliriz?
İyi hafta sonu dileğimle ,iyi çalışmalar dilerim.

Merhaba.
İstediğiniz şekilde dosyayı hazırladım.
Dosyayı güncelledim.

Sub grupla()
Dim i As Long, k As Byte, topla As Double, sonsata As Long, sonsatb As Long
Sheets("Sayfa1").Select
sonsata = Cells(65536, "A").End(xlUp).Row
Range("A1:B" & sonsata).Interior.ColorIndex = xlNone
For i = 1 To sonsata
    If Cells(i, "A").Value = Range("E1").Value Then
        For k = 1 To 4
            If Cells(i + k, "A").Value <> Cells(k + 1, "E").Value Then GoTo atla
        Next
        Cells(i, "A").Interior.ColorIndex = 6
        For k = 1 To 4
            Cells(i + k, "A").Interior.ColorIndex = 6
        Next
        i = i + 4
        topla = topla + 1
    End If
atla:
Next i
Range("C1").Value = topla * 1
Range("C1").NumberFormat = "#,##0.00"
sonsatb = Cells(65536, "B").End(xlUp).Row
topla = 0
For i = 1 To sonsatb
    If Cells(i, "B").Value = Range("F1").Value Then
        For k = 1 To 4
            If Cells(i + k, "B").Value <> Cells(k + 1, "F").Value Then GoTo atla2
        Next
        Cells(i, "B").Interior.ColorIndex = 8
        For k = 1 To 4
        Cells(i + k, "B").Interior.ColorIndex = 8
        Next
        i = i + 4
        topla = topla + 1
    End If
atla2:
Next i
Range("D1").Value = topla * 1
Range("D1").NumberFormat = "#,##0.00"
MsgBox "GRUPLAMA TAMAMLANDI", vbOKOnly, Application.UserName
End Sub

 

[arol11]

Tammam sayın Sezar,
Bu tip sorular aklıma gelmiyor fakat düşününce uygulayabilir olduğumu anlayınca ,gereksiz topik açmaktansa hemen sormayı yeğliyorum.Umarım sayın daali ve sizler yanlış anlamazsınız,beni bağışlayınız.
Ayrıca kodlarınız çalıştı fakat 1. grup için renklendirmede 1. değeri renklendirmiyor diğer son 4 değeri renklendiriyor.Bunu bilgilerinize sunmak istedim.
Tekrar çok teşekkür ederim,kolay gelsin.

 

[Orion1]

Tammam sayın Sezar,
Bu tip sorular aklıma gelmiyor fakat düşününce uygulayabilir olduğumu anlayınca ,gereksiz topik açmaktansa hemen sormayı yeğliyorum.Umarım sayın daali ve sizler yanlış anlamazsınız,beni bağışlayınız.
Ayrıca kodlarınız çalıştı fakat 1. grup için renklendirmede 1. değeri renklendirmiyor diğer son 4 değeri renklendiriyor.Bunu bilgilerinize sunmak istedim.
Tekrar çok teşekkür ederim,kolay gelsin.

Sayın Arol11 1nci grubun renklendirilmesi düzeltildi.
Dosya güncellendi .Önceki mesajımdan indirebilirsiniz.

 

[arol11]

Çok zahmet oldu Sayın Sezar ,teşekkür ederim ilginize.

 

[Orion1]

Çok zahmet oldu Sayın Sezar ,teşekkür ederim ilginize.

Rica ederim.
İyi çalışmalar.

 

[veyselemre]

@Sezar çok güzel cevap vermiş ama bir alternatif de ben vereyim.

Sub GrupAraBulBicimlendir()
'veyselemre
'www.excel.web.tr
'140707
    Intersect(ActiveSheet.UsedRange, [A:B]).Interior.ColorIndex = xlNone

    sut = 1: renk = 6: bak = [E1:E5].Value
    GoSub islem

    [c1] = say

    sut = 2: renk = 8: bak = [F1:F5].Value
    GoSub islem
    [d1] = say

    Exit Sub
islem:
    say = 0
    son = Cells(65536, sut).End(3).Row
    For x = 1 To son
        a = Cells(x, sut).Resize(5).Value
        If AralikAyni(bak, a) Then
            Cells(x, sut).Resize(5).Interior.ColorIndex = renk
            x = x + 4
            say = say + 1
        End If

    Next x
    Return
End Sub
Function AralikAyni(d1, d2) As Boolean
    AralikAyni = True
    For x = LBound(d1) To UBound(d1)
        If d1(x, 1) <> d2(x, 1) Then
            AralikAyni = False
            Exit Function
        End If
    Next x
End Function

 

[daali]

Oooo maşallah,emeğinize sağlık Sayın Sezar ve veyselemre,
Ayrıca arol11 sizede teşekkürler katkıda bulunduğunuz için.
Saygılarımla.

 

[arol11]

Sayın orion2 ve veyselemre bu uygulama üzerinde yeni çalışmaya başladım.Firmamızın çeşitli makul gerekçelerle(motivasyon,güvenlik,ekonomik .) araçların periyodik çıkış ve varış güzergahlarını saptamak ve sürücülerin bilerek ve isteyerek bu güzergahlarda yönlendirildiklerinin ,çalışıp çalışmadıklarının saptamak,istatistiki değerlere ulaşmak olarak hazırlayacağım bu listede gerekli olan sorunları kısaca özetledim.Eğer sizin değerli zamanlarınızı fazlaca meşgul etmeyecekse ilgilenebilmeniz mümkün olurmu?
İyi çalışmalar ve başarılar dilerim.

 

[Orion1]

Merhaba.
Ekli dosyayı inceleyiniz.Bu şekildemi olsun.
Kodlar C sütununu geçici olarak kullanıyor.

 

[arol11]

Selamlar sayın orion2,
Verdiğiniz dosyayı inceliyorum.Eklediğim dosyaya gözatabilirseniz daha net olacak sanırım çözümünüz.
İyi çalışmalar ve başarılar dilerim sayın orion2.

 

[Orion1]

Merhaba.
Sorunun birinci bölümü için bir önceki mesajımdan dosyayı indirip incelermisiniz.

 

[arol11]

İyi geceler sayın orion2,
Grup renklemesi tammam fakat grup sayısının toplam ne kadar, kaç tane olduğunu hesaplamadı.
İyi çalışmalar ve başarılar dilerim.

 

[Orion1]

Merhaba.
Önceki mesajımdan indirip deneyebilirsiniz.
E sütununda formüller var.

 

[omerikis]

paylaşım için teşekkürler

 

[Orion1]

Bir hata tesbit ettim.
Hatayı düzelttim.12nci mesajdan dosyayı indirebilirsiniz.

 

[arol11]

İyi akşamlar
Dosyanızdaki formülü düzelttim ve artık sayı hesabı bir kenara dursun eklediğim dosyaya tekrar göz atabilirseniz eğer ,renkleme ile sayı toplamının uyuşması gerekliydi.Açıklamalar yaptım dosyada.
İyi çalışmalar ve başarılar dilerim.

 

[Orion1]

12nci mesajımdan indirip kodları deneyiniz.
İstediğiniz Bu şekildemi?