DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
merhabaekledim
tşk
=TOPLA.ÇARPIM(([COLOR="Red"]$A$4:$A$11[/COLOR]=$D5)*([COLOR="red"]$B$4:$B$11[/COLOR]=E$4))
Sub mukerrer_topla_59()
Dim z As Object, liste(), myarr(), n As Long, sat As Long
Dim firma As String, i As Long
Sheets("Sayfa1").Select
Range("D5:F65536").ClearContents
sat = Cells(65536, "A").End(xlUp).Row
If sat < 4 Then Exit Sub
liste = Range("A4:B" & sat).Value
ReDim myarr(1 To 3, 1 To sat)
Set z = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(liste)
firma = UCase(Replace(Replace(liste(i, 1), "i", "İ"), "ı", "I"))
If Not z.exists(firma) Then
n = n + 1
z.Add firma, n
myarr(1, n) = liste(i, 1)
myarr(2, n) = 0
myarr(3, n) = 0
End If
If UCase(Replace(Replace(liste(i, 2), "i", "İ"), "ı", "I")) = "İLK" Then
myarr(2, z.Item(firma)) = myarr(2, z.Item(firma)) + 1
Else
myarr(3, z.Item(firma)) = myarr(3, z.Item(firma)) + 1
End If
Next i
Application.ScreenUpdating = False
Erase liste: Set z = Nothing
Range("D5").Resize(n, 3) = Application.Transpose(myarr)
Erase myarr
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı" & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
syn : mersilenselam
alternatif olsun
e5 hücresine
=ÇOKEĞERSAY($A$4:$A$11;D5;$B$4:$B$11;E$4)
yapıştırabilirsin
öncelikle evren hoca'ma teşekkür ederimarkadaşlar hepinize ayrı ayrı teşekkür ederim
İhsan Bey ilk ve yeni ayrı ayrı sayımıyor galiba zira sonuçtaki ilk sütun değerleri sıfır çıkıyor
Sn Evren Gizlen önerisini denemedim henüz, kullandığım excel 2003
tşk
rica ederimtamamdır sayın Tanık
hepinizin ellerine sağlık teşekkür ederim