• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Grup olanları bulmak ,renklendirmek ve saymak.

  • Konbuyu başlatan Konbuyu başlatan daali
  • Başlangıç tarihi Başlangıç tarihi
Selamlar,

Sn. arol11,

F sütununda en fazla kaç şehir ismi seçiyorsunuz.
 
Selamlar,

En son eklediğiniz örnek dosyaya göre aşağıdaki kodları denermisiniz.

Kod: 
Sub GRUPLA()
    Sheets("Sayfa1").Select
    Columns(2).Interior.ColorIndex = xlNone
    For X = [B65536].End(3).Row To 2 Step -1
    If Cells(X, 2) = Cells(1, 6) Then
    If Cells(X + 1, 2) = Cells(2, 6) Then
    If Cells(X + 2, 2) = Cells(3, 6) Then
    Range(Cells(X, 2), Cells(X + 2, 2)).Interior.ColorIndex = 8
    End If: End If: End If
    Next
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub
 
Sayın Arol11
İstediğiniz değişikliği yaptım.
Formülleri değişitrmeyiniz.Kodlar ne sonuç üretiyorsa formüllerde o sonucu veriyor.Kodlar doğru sonuç ürettiğinde formüllerde doğru sonucu verecektir.:cool:
Kod: 
Sub grupla()
Dim i As Long, k As Byte, sonsata As Long, sonsatb As Long
Dim sayac As Byte
Sheets("Sayfa1").Select
sonsata = Cells(65536, "A").End(xlUp).Row
sonsatb2 = Cells(65536, "B").End(xlUp).Row
Application.ScreenUpdating = False
Range("A1:B" & sonsata).Interior.ColorIndex = xlNone
Range("D2:D65536").ClearContents
Range("C2:C65536").Clear
sat = 1
'===================================================================
For i = 1 To sonsatb2
    For y = i To i + Cells(65536, "F").End(xlUp).Row
        If Cells(y, "B").Value = Cells(sat, "F").Value Then
            sat = sat + 1
            sayac = sayac + 1
            If sayac >= 3 Then Exit For
            Else
            sayac = 0
            sat = 1
            Exit For
        End If
    Next y
   If sayac >= 3 Then
        For y = i To i + Cells(65536, "F").End(xlUp).Row - 1
            Cells(y, "B").Interior.ColorIndex = 8
            Cells(y, "D").Value = 1
        Next y
    End If
Next i
Range("C2:C65536").Clear
Application.ScreenUpdating = True
MsgBox "GRUPLAMA TAMAMLANDI", vbOKOnly, Application.UserName
End Sub
 
İyi akşamlar,
Bu konu oldukça uzadı.Sayın Orion2 tüm emeklerinize şükranlarımı sunarım.Sayın COSTCONTROL F sutununda seçim sayısı değişiklik gösteriyor.Duruma göre verimlilik,ihbar vs. gibi nedenlerle(gözlem sonuçlarına göre ,artabilirde) sayı 8 e kadar çıkabiliyor.Bu 8 satıra kadar fakat istendiğindede 2 yada 3 yada 4 ...güzergah içinde otomatik uygulanabilir olması için kodlarda ne gibi bir değişiklik yapabilirsiniz.Eğer bir öneri sunarsanız bu konuyu kapatmak istiyorum artık.
Herşey gönlünüzce olsun .
İyi çalışmalar ve başarılar dilerim.:hey:
 
Selamlar,

Kodu aşağıdaki şekilde değiştirip denermisiniz.

Bu haliyle en fazla 8 grup için çalışır. Koda ekleme yaparak grup sayısını arttırabilirsiniz.

Kod: 
Sub GRUPLA()
    Sheets("Sayfa1").Select
    Columns(2).Interior.ColorIndex = xlNone
    SAY = WorksheetFunction.CountA(Columns(6))
    If SAY = 0 Then Exit Sub
    
    For X = 2 To [B65536].End(3).Row
    If SAY = 1 Then
    If Cells(X, 2) = Cells(1, 6) Then
    Cells(X, 2).Interior.ColorIndex = 8
    End If: End If
    
    If SAY = 2 Then
    If Cells(X, 2) = Cells(1, 6) Then
    If Cells(X + 1, 2) = Cells(2, 6) Then
    Range(Cells(X, 2), Cells(X + 1, 2)).Interior.ColorIndex = 8
    End If: End If: End If
    If SAY = 3 Then
    If Cells(X, 2) = Cells(1, 6) Then
    If Cells(X + 1, 2) = Cells(2, 6) Then
    If Cells(X + 2, 2) = Cells(3, 6) Then
    Range(Cells(X, 2), Cells(X + 2, 2)).Interior.ColorIndex = 8
    End If: End If: End If: End If

    If SAY = 4 Then
    If Cells(X, 2) = Cells(1, 6) Then
    If Cells(X + 1, 2) = Cells(2, 6) Then
    If Cells(X + 2, 2) = Cells(3, 6) Then
    If Cells(X + 3, 2) = Cells(4, 6) Then
    Range(Cells(X, 2), Cells(X + 3, 2)).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If
    
    If SAY = 5 Then
    If Cells(X, 2) = Cells(1, 6) Then
    If Cells(X + 1, 2) = Cells(2, 6) Then
    If Cells(X + 2, 2) = Cells(3, 6) Then
    If Cells(X + 3, 2) = Cells(4, 6) Then
    If Cells(X + 4, 2) = Cells(5, 6) Then
    Range(Cells(X, 2), Cells(X + 4, 2)).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If: End If
    
    If SAY = 6 Then
    If Cells(X, 2) = Cells(1, 6) Then
    If Cells(X + 1, 2) = Cells(2, 6) Then
    If Cells(X + 2, 2) = Cells(3, 6) Then
    If Cells(X + 3, 2) = Cells(4, 6) Then
    If Cells(X + 4, 2) = Cells(5, 6) Then
    If Cells(X + 5, 2) = Cells(6, 6) Then
    Range(Cells(X, 2), Cells(X + 5, 2)).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If: End If: End If
    
    If SAY = 7 Then
    If Cells(X, 2) = Cells(1, 6) Then
    If Cells(X + 1, 2) = Cells(2, 6) Then
    If Cells(X + 2, 2) = Cells(3, 6) Then
    If Cells(X + 3, 2) = Cells(4, 6) Then
    If Cells(X + 4, 2) = Cells(5, 6) Then
    If Cells(X + 5, 2) = Cells(6, 6) Then
    If Cells(X + 6, 2) = Cells(7, 6) Then
    Range(Cells(X, 2), Cells(X + 6, 2)).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If: End If: End If: End If
    
    If SAY = 8 Then
    If Cells(X, 2) = Cells(1, 6) Then
    If Cells(X + 1, 2) = Cells(2, 6) Then
    If Cells(X + 2, 2) = Cells(3, 6) Then
    If Cells(X + 3, 2) = Cells(4, 6) Then
    If Cells(X + 4, 2) = Cells(5, 6) Then
    If Cells(X + 5, 2) = Cells(6, 6) Then
    If Cells(X + 6, 2) = Cells(7, 6) Then
    If Cells(X + 7, 2) = Cells(8, 6) Then
    Range(Cells(X, 2), Cells(X + 7, 2)).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If: End If: End If: End If: End If
    Next
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub
 
İyi akşamlar,
Çok teşekkürler,birkaç gündür forumdan uzaktaydım.Sayın orion2 ve COSTCONTROL sağolun.
İyi çalışmalar ve başarılar diler ,herşeyin gönlünüzce devam etmesini can-ı yürekten dilerim.
İyi akşamlar.
 
İyi geceler,
Sayın cost control ve orion2 ,
İkinci sorum için yeni bir dosya hazırladım.Mümkün olursa yeni bir makro çözüm yapabilirmisiniz?
İyi çalışmalar ve başarılar dilerim.
 
Selamlar,

İncelediğim kadarıyla örnek dosyanızda E5-F5 hücreleri ile A27-B27 hücreleri eşleşmediği halde renklendirme uygulamışsınız. Burada nasıl bir kretere göre renklendirme olacak açıklar mısınız?
 
Son düzenleme:
İyi geceler,
F sutununlarındaki değerleri ARDARDA B sutununda bulup renklendirmiştiniz.Yeni farkettim ,haklısınız.Bunlar eşleşiyor.F5 Ankara olacaktı.
OK,iyi çalışmalar.
 
Selamlar,

Aşağıdaki kodu denermisiniz. 10 adet gruplama için düzenlenmiştir.

Kod: 
Sub GRUPLA()
    Sheets("Sayfa1").Select
    [A:B].Interior.ColorIndex = xlNone
    say = WorksheetFunction.CountA(Columns(6))
    If say = 0 Then Exit Sub
    
    For x = 2 To [B65536].End(3).Row
    
    If say = 1 Then
    If Cells(x, 1) = Cells(1, 5) And Cells(x, 2) = Cells(1, 6) Then
    Range("A" & x & ":B" & x).Interior.ColorIndex = 8
    End If: End If
    
    If say = 2 Then
    If Cells(x, 1) = Cells(1, 5) And Cells(x, 2) = Cells(1, 6) Then
    If Cells(x + 1, 1) = Cells(2, 5) And Cells(x + 1, 2) = Cells(2, 6) Then
    Range("A" & x & ":B" & x + 1).Interior.ColorIndex = 8
    End If: End If: End If
    
    If say = 3 Then
    If Cells(x, 1) = Cells(1, 5) And Cells(x, 2) = Cells(1, 6) Then
    If Cells(x + 1, 1) = Cells(2, 5) And Cells(x + 1, 2) = Cells(2, 6) Then
    If Cells(x + 2, 1) = Cells(3, 5) And Cells(x + 2, 2) = Cells(3, 6) Then
    Range("A" & x & ":B" & x + 2).Interior.ColorIndex = 8
    End If: End If: End If: End If

    If say = 4 Then
    If Cells(x, 1) = Cells(1, 5) And Cells(x, 2) = Cells(1, 6) Then
    If Cells(x + 1, 1) = Cells(2, 5) And Cells(x + 1, 2) = Cells(2, 6) Then
    If Cells(x + 2, 1) = Cells(3, 5) And Cells(x + 2, 2) = Cells(3, 6) Then
    If Cells(x + 3, 1) = Cells(4, 5) And Cells(x + 3, 2) = Cells(4, 6) Then
    Range("A" & x & ":B" & x + 3).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If
    
    If say = 5 Then
    If Cells(x, 1) = Cells(1, 5) And Cells(x, 2) = Cells(1, 6) Then
    If Cells(x + 1, 1) = Cells(2, 5) And Cells(x + 1, 2) = Cells(2, 6) Then
    If Cells(x + 2, 1) = Cells(3, 5) And Cells(x + 2, 2) = Cells(3, 6) Then
    If Cells(x + 3, 1) = Cells(4, 5) And Cells(x + 3, 2) = Cells(4, 6) Then
    If Cells(x + 4, 1) = Cells(5, 5) And Cells(x + 4, 2) = Cells(5, 6) Then
    Range("A" & x & ":B" & x + 4).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If: End If
    
    If say = 6 Then
    If Cells(x, 1) = Cells(1, 5) And Cells(x, 2) = Cells(1, 6) Then
    If Cells(x + 1, 1) = Cells(2, 5) And Cells(x + 1, 2) = Cells(2, 6) Then
    If Cells(x + 2, 1) = Cells(3, 5) And Cells(x + 2, 2) = Cells(3, 6) Then
    If Cells(x + 3, 1) = Cells(4, 5) And Cells(x + 3, 2) = Cells(4, 6) Then
    If Cells(x + 4, 1) = Cells(5, 5) And Cells(x + 4, 2) = Cells(5, 6) Then
    If Cells(x + 5, 1) = Cells(6, 5) And Cells(x + 5, 2) = Cells(6, 6) Then
    Range("A" & x & ":B" & x + 5).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If: End If: End If
    
    If say = 7 Then
    If Cells(x, 1) = Cells(1, 5) And Cells(x, 2) = Cells(1, 6) Then
    If Cells(x + 1, 1) = Cells(2, 5) And Cells(x + 1, 2) = Cells(2, 6) Then
    If Cells(x + 2, 1) = Cells(3, 5) And Cells(x + 2, 2) = Cells(3, 6) Then
    If Cells(x + 3, 1) = Cells(4, 5) And Cells(x + 3, 2) = Cells(4, 6) Then
    If Cells(x + 4, 1) = Cells(5, 5) And Cells(x + 4, 2) = Cells(5, 6) Then
    If Cells(x + 5, 1) = Cells(6, 5) And Cells(x + 5, 2) = Cells(6, 6) Then
    If Cells(x + 6, 1) = Cells(7, 5) And Cells(x + 6, 2) = Cells(7, 6) Then
    Range("A" & x & ":B" & x + 6).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If: End If: End If: End If
    
    If say = 8 Then
    If Cells(x, 1) = Cells(1, 5) And Cells(x, 2) = Cells(1, 6) Then
    If Cells(x + 1, 1) = Cells(2, 5) And Cells(x + 1, 2) = Cells(2, 6) Then
    If Cells(x + 2, 1) = Cells(3, 5) And Cells(x + 2, 2) = Cells(3, 6) Then
    If Cells(x + 3, 1) = Cells(4, 5) And Cells(x + 3, 2) = Cells(4, 6) Then
    If Cells(x + 4, 1) = Cells(5, 5) And Cells(x + 4, 2) = Cells(5, 6) Then
    If Cells(x + 5, 1) = Cells(6, 5) And Cells(x + 5, 2) = Cells(6, 6) Then
    If Cells(x + 6, 1) = Cells(7, 5) And Cells(x + 6, 2) = Cells(7, 6) Then
    If Cells(x + 7, 1) = Cells(8, 5) And Cells(x + 7, 2) = Cells(8, 6) Then
    Range("A" & x & ":B" & x + 7).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If: End If: End If: End If: End If
    
    If say = 9 Then
    If Cells(x, 1) = Cells(1, 5) And Cells(x, 2) = Cells(1, 6) Then
    If Cells(x + 1, 1) = Cells(2, 5) And Cells(x + 1, 2) = Cells(2, 6) Then
    If Cells(x + 2, 1) = Cells(3, 5) And Cells(x + 2, 2) = Cells(3, 6) Then
    If Cells(x + 3, 1) = Cells(4, 5) And Cells(x + 3, 2) = Cells(4, 6) Then
    If Cells(x + 4, 1) = Cells(5, 5) And Cells(x + 4, 2) = Cells(5, 6) Then
    If Cells(x + 5, 1) = Cells(6, 5) And Cells(x + 5, 2) = Cells(6, 6) Then
    If Cells(x + 6, 1) = Cells(7, 5) And Cells(x + 6, 2) = Cells(7, 6) Then
    If Cells(x + 7, 1) = Cells(8, 5) And Cells(x + 7, 2) = Cells(8, 6) Then
    If Cells(x + 8, 1) = Cells(9, 5) And Cells(x + 8, 2) = Cells(9, 6) Then
    Range("A" & x & ":B" & x + 8).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If: End If: End If: End If: End If: End If
    
    If say = 10 Then
    If Cells(x, 1) = Cells(1, 5) And Cells(x, 2) = Cells(1, 6) Then
    If Cells(x + 1, 1) = Cells(2, 5) And Cells(x + 1, 2) = Cells(2, 6) Then
    If Cells(x + 2, 1) = Cells(3, 5) And Cells(x + 2, 2) = Cells(3, 6) Then
    If Cells(x + 3, 1) = Cells(4, 5) And Cells(x + 3, 2) = Cells(4, 6) Then
    If Cells(x + 4, 1) = Cells(5, 5) And Cells(x + 4, 2) = Cells(5, 6) Then
    If Cells(x + 5, 1) = Cells(6, 5) And Cells(x + 5, 2) = Cells(6, 6) Then
    If Cells(x + 6, 1) = Cells(7, 5) And Cells(x + 6, 2) = Cells(7, 6) Then
    If Cells(x + 7, 1) = Cells(8, 5) And Cells(x + 7, 2) = Cells(8, 6) Then
    If Cells(x + 8, 1) = Cells(9, 5) And Cells(x + 8, 2) = Cells(9, 6) Then
    If Cells(x + 9, 1) = Cells(10, 5) And Cells(x + 9, 2) = Cells(10, 6) Then
    Range("A" & x & ":B" & x + 9).Interior.ColorIndex = 8
    End If: End If: End If: End If: End If: End If: End If: End If: End If: End If: End If
    Next
    MsgBox "İŞLEMİNİZ TAMAMLANMIŞTIR.", vbInformation
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst