Aynı sayıların hepsini bulma

[serseri26]

merhaba arkadaşlar

benim bir adet kodum var bu kodda bir aralıkta tanımladığım sayıyı arattırıyorum.Fakat aynı sayı iki yada daha fazla olduğu zaman belirlediğim hücreye 1 arttırım yapmasını istiyorum.Kendi hazırladığım kod ile arattığım sayı varsa 1 adet arttırım yapıyor fakat o sayıdan 2 adet yada daha fazla olduğu zaman ne kadar bulduğu sayı varsa o kadar arttırım yapmasını istiyorum.Kod örneği aşağıdadır.

teşekkürler

Sub sonuc2()
For a = 1 To 8
For b = 2 To 50
If (Not Cells(b, a + 75).Value = "" And Not Cells(b, 87).Value = "") Then
Cells(a + 1, 127).Value = Cells(a + 1, 127) + 1
End If
Next b
Next a
Set bul = Range("DW1W20").Find(6)
On Error Resume Next
If Not bul Is Nothing Then
Range("ED3").Value = Range("ED3") + 1
End If
Set bul = Range("DW1W20").Find(7)
If Not bul Is Nothing Then
Range("ED4").Value = Range("ED4") + 1
End If
On Error Resume Next
Set bul = Range("DW1W20").FindNext(bul)
If Not bul Is Nothing Then
Range("ED4").Value = Range("ED4") + 1
End If
Set bul = Range("DW1W20").Find(8)
If Not bul Is Nothing Then
Range("ED5").Value = Range("ED5") + 1
End If
On Error Resume Next
Set bul = Range("DW1W20").FindNext(bul)
If Not bul Is Nothing Then
Range("ED5").Value = Range("ED5") + 1
End If
Set bul = Range("DW1W20").Find(9)
If Not bul Is Nothing Then
Range("ED6").Value = Range("ED6") + 1
End If
On Error Resume Next
Set bul = Range("DW1W20").FindNext(bul)
If Not bul Is Nothing Then
Range("ED6").Value = Range("ED6") + 1
End If
Set bul = Range("DW1W20").Find(10)
If Not bul Is Nothing Then
Range("ED7").Value = Range("ED7") + 1
End If
On Error Resume Next
Set bul = Range("DW1W20").FindNext(bul)
If Not bul Is Nothing Then
Range("ED7").Value = Range("ED7") + 1
End If
End Sub

 

[Korhan Ayhan]

Selamlar,

Bu işlemi döngü ile rahatlıkla yapabilirsiniz. Aşağıdaki kodu kendinize uyarlamaya çalışın. Eğer istediğiniz farklı birşeyse lütfen örnek dosya ekleyerek sorunuzu detaylıca açıklayın.

Option Explicit
 
Sub SAYILARI_BUL()
    Dim HÜCRE As Range
    
    Range("ED3:ED7").ClearContents
    
    For Each HÜCRE In Range("DW1:DW20")
        Select Case HÜCRE.Value
            Case Is = 6
            Range("ED3").Value = Range("ED3") + 1
            Case Is = 7
            Range("ED4").Value = Range("ED4") + 1
            Case Is = 8
            Range("ED5").Value = Range("ED5") + 1
            Case Is = 9
            Range("ED6").Value = Range("ED6") + 1
            Case Is = 10
            Range("ED7").Value = Range("ED7") + 1
        End Select
    Next
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Orion1]

Alternatif.

Sub SAYILARI_BUL()
    Range("ED3:ED7").ClearContents
    Range("ED3").Value = WorksheetFunction.CountIf(Range("DW1:DW20"), 6)
    Range("ED4").Value = WorksheetFunction.CountIf(Range("DW1:DW20"), 7)
    Range("ED5").Value = WorksheetFunction.CountIf(Range("DW1:DW20"), 8)
    Range("ED6").Value = WorksheetFunction.CountIf(Range("DW1:DW20"), 9)
    Range("ED7").Value = WorksheetFunction.CountIf(Range("DW1:DW20"), 10)
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[serseri26]

Teşekkürler korhan bey istediğimi sizin kodunuzla halletim.Evren beyin verdiği kod her çalıştırıldığında diğer verilerin üzerine yazdığı için benim istediğim sonucu vermedi sizinki kodu her çalıştırdığımda üzerine ekleme yapıyor.istediğim olay buydu zaten tekrardan teşekkür ederim

not:Evren bey sizede teşekkür ederim

 

[Orion1]

Teşekkürler korhan bey istediğimi sizin kodunuzla halletim.Evren beyin verdiği kod her çalıştırıldığında diğer verilerin üzerine yazdığı için benim istediğim sonucu vermedi sizinki kodu her çalıştırdığımda üzerine ekleme yapıyor.istediğim olay buydu zaten tekrardan teşekkür ederim

not:Evren bey sizede teşekkür ederim

Evet eğersay formülünü yanlışlıkla kullanmışım.
Tekrar düzenledim.
Kodlar aşağıdadır

Sub SAYILARI_BUL()
    Range("ED3:ED7").ClearContents
    Range("ED3").Value = WorksheetFunction.Sumif(Range("DW1:DW20"), 6,Range("DW1:DW20"))
    Range("ED4").Value = WorksheetFunction.Sumif(Range("DW1:DW20"), 7,Range("DW1:DW20"))
    Range("ED5").Value = WorksheetFunction.Sumif(Range("DW1:DW20"), 8,Range("DW1:DW20"))
    Range("ED6").Value = WorksheetFunction.Sumif(Range("DW1:DW20"), 9,Range("DW1:DW20"))
    Range("ED7").Value = WorksheetFunction.Sumif(Range("DW1:DW20"), 10,Range("DW1:DW20"))
    MsgBox "İşleminiz tamamlanmıştır." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[serseri26]

evren bey ilginiz için tşk

 

[Orion1]

evren bey ilginiz için tşk

Rica ederim.