Sütunlardaki verileri sayma ve adetlerini karşılaştırma

[kuschcu]

Ekteki dosyada bulunan sayfa1'de 1.sütun ve 2.sütundaki rakamlardan

1. kaçar adet oldukları yanlarına eklenecek birer sütunda belirtilmesi,

2. Kaçar adet oldukları belli olduktan sonra 1.sütun ve 2.sütundaki rakamlardan adet olarak birbirini tutmayanların hücre renginin değiştirilmesi,

için makro ile bir çözüm geliştirilebilir mi?


Dosya ektedir. Kıymetli yardımlarınızı bekliyorum.

Saygılarımla,

 

[İhsan Tank]

Merhaba
Sorunuzu tam olarak anlamadım. Biraz daha açıklama yapar mısınız. Dosya içinde örneklerle yaparsanız daha iyi olur

 

[hımmmmmmmm]

slm

ekdeki dosyayı incele... yanlış anlama varsa sonra bakarlım...

 

[kuschcu]

Canlar, ilginiz için çok teşekkür ederim. Ekte gönderdiğiniz dosyayı incelemedim. Talebimi anlatamadığımı anladım.

Tekrar ek dosya yolluyorum. Bu sefer daha düzgün anlattım. Dosya ektedir.

Yardımlarınız için teşekkür ederim.

 

[İhsan Tank]

Canlar, ilginiz için çok teşekkür ederim. Ekte gönderdiğiniz dosyayı incelemedim. Talebimi anlatamadığımı anladım.

Tekrar ek dosya yolluyorum. Bu sefer daha düzgün anlattım. Dosya ektedir.

Yardımlarınız için teşekkür ederim.

Merhaba
Eşitlik için bunu deneyin.

Option Explicit
Sub eşitlik_61()
Dim ts
For ts = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(ts, "C") = WorksheetFunction.CountIf(Range("A:A"), Cells(ts, "A"))
Cells(ts, "D") = WorksheetFunction.CountIf(Range("B:B"), Cells(ts, "B"))
Next
End Sub

Boyamayı anlamadım.

 

[kuschcu]

Merhaba
Eşitlik için bunu deneyin.

Option Explicit
Sub eşitlik_61()
Dim ts
For ts = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(ts, "C") = WorksheetFunction.CountIf(Range("A:A"), Cells(ts, "A"))
Cells(ts, "D") = WorksheetFunction.CountIf(Range("B:B"), Cells(ts, "B"))
Next
End Sub

Boyamayı anlamadım.

Bir önceki mesajımda "incelemedim" demişim o yanlış olmuş "inceledim" olacaktı.

İhsan Bey, kodunuzu işe gidince deneyeceğim. Boyamadan kastım 1.sütundaki ve 2.sütundaki aynı rakamların adetleri birbirine eşit olmayan rakamların hücre içi renklerinin farklı olmasıdır.

Sizin kodunuz sanırım adetleri sayacak "C" ve "D" sütunlarına yazdıracak. Yani ilk aşamayı sizin kodlar ile halletmiş olduğumu düşünüyorum.

şimdi 2nci aşama olan yukarıda dediğim gibi
1.sütundaki ve 2.sütundaki aynı rakamların adetleri noktasında birbirine eşit olmayan rakamların hücre içi renklerinin farklı olmasıdır.
örneğin 1.sütunda 9 rakamından 10 tane var. 2.sütunda 8 tane var ise. Hem 1.sütunda hem 2.sütunda "9" rakamı geçen tüm hücrelerin hücre rengi mesela kırmızı olsun gibi.

Yardımlarınız için teşekkürler. Saygılarımla,

 

[İhsan Tank]

Bir önceki mesajımda "incelemedim" demişim o yanlış olmuş "inceledim" olacaktı.

İhsan Bey, kodunuzu işe gidince deneyeceğim. Boyamadan kastım 1.sütundaki ve 2.sütundaki aynı rakamların adetleri birbirine eşit olmayan rakamların hücre içi renklerinin farklı olmasıdır.

Sizin kodunuz sanırım adetleri sayacak "C" ve "D" sütunlarına yazdıracak. Yani ilk aşamayı sizin kodlar ile halletmiş olduğumu düşünüyorum.

şimdi 2nci aşama olan yukarıda dediğim gibi
1.sütundaki ve 2.sütundaki aynı rakamların adetleri noktasında birbirine eşit olmayan rakamların hücre içi renklerinin farklı olmasıdır.
örneğin 1.sütunda 9 rakamından 10 tane var. 2.sütunda 8 tane var ise. Hem 1.sütunda hem 2.sütunda "9" rakamı geçen tüm hücrelerin hücre rengi mesela kırmızı olsun gibi.

Yardımlarınız için teşekkürler. Saygılarımla,

Merhaba
bu kodu dener misiniz_?

Option Explicit
Sub eşitlik_61()
Dim ts, trabzonspor, hamsi As Date
trabzonspor = MsgBox("Sayım Yapıyorum Ayrıca Adetleri" _
& "Tutmayanı Boyuyorum", vbYesNo, "Onay")
If trabzonspor = vbNo Then Exit Sub
Application.ScreenUpdating = False
hamsi = Time
Cells.Interior.ColorIndex = xlNone
For ts = 2 To Cells(Rows.Count, "A").End(xlUp).Row
Cells(ts, "C") = WorksheetFunction.CountIf(Range("A:A"), Cells(ts, "A"))
Cells(ts, "D") = WorksheetFunction.CountIf(Range("B:B"), Cells(ts, "B"))
Cells(ts, "E") = Cells(ts, "A") & "_" & Cells(ts, "C")
Cells(ts, "F") = Cells(ts, "B") & "_" & Cells(ts, "D")
Next
For ts = 2 To Cells(Rows.Count, "A").End(xlUp).Row
If WorksheetFunction.CountIf(Range("F:F"), Cells(ts, "E")) = 0 Then
Range("A" & ts & ":D" & ts).Interior.ColorIndex = 3
End If
Next
Range("E:F").ClearContents
Application.ScreenUpdating = True
MsgBox Format(hamsi - Time, "hh:mm:ss") & vbLf _
& "Sürede Sayım Yaptım ve Boyama Yaptım", , "Bitiş"
End Sub

 

[kuschcu]

İhsan Bey, çok teşekkürler kodlarınız işimi gördü.

Tekrar görüşmek dileğiyle..

Saygılarımı sunarım.

 

[İhsan Tank]

İhsan Bey, çok teşekkürler kodlarınız işimi gördü.

Tekrar görüşmek dileğiyle..

Saygılarımı sunarım.

Rica ederim
:keyif: