Fonksiyona renk kontrolu eklenmesi

[shairane]

Merhabalar;

Asagida verilmis olan fonksiyon koduna renk kontrolu eklemek istiyorum. bunu nasil yaparim? Mesela sozkonusu sayim sonucunun yalnizca kirmizi renkteki sekilleri icermesi icin fonksiyon tanimina nasil bir ekleme yapmaliyiz?

Tesekkur ederim.

Function Headcount(ShapeType As MsoAutoShapeType, Optional Target As Range) As Long
Dim sh As Worksheet, shp As Shape, cnt As Long

If Target Is Nothing Then

For Each sh In ThisWorkbook.Sheets
For Each shp In sh.Shapes
If shp.Type = ShapeType Then
cnt = cnt + 1
End If
Next
Next

Else

For Each shp In Target.Parent.Shapes
If shp.AutoShapeType = ShapeType Then
If Not Intersect(shp.TopLeftCell, Target) Is Nothing _
And Not Intersect(shp.BottomRightCell, Target) Is Nothing Then
 cnt = cnt + 1
 End If
 End If
 Next

 End If

 Headcount = cnt
End Function

 

[Ferhat Pazarçevirdi]

Merhabalar

Kodunuzu aşağıdaki şekliyle revize ediniz.

Function Headcount(ShapeType As MsoAutoShapeType, Optional Target As Range) As Long
Dim sh As Worksheet, shp As Shape, cnt As Long
If Target Is Nothing Then
   For Each sh In ThisWorkbook.Sheets
       For Each shp In sh.Shapes
           If shp.Type = ShapeType Then
              If shp.Fill.ForeColor.SchemeColor = 10 Then
                 cnt = cnt + 1
              End If
           End If
       Next
   Next
Else
   For Each shp In Target.Parent.Shapes
[COLOR=green]'       If shp.AutoShapeType = ShapeType Then[/COLOR]
          If Not Intersect(shp.TopLeftCell, Target) Is Nothing _
             And Not Intersect(shp.BottomRightCell, Target) Is Nothing Then
              If shp.Fill.ForeColor.SchemeColor = 10 Then
                 cnt = cnt + 1
              End If
          End If
[COLOR=green]'       End If[/COLOR]
   Next
End If
Headcount = cnt
End Function

 

[shairane]

Cevabiniz icin cok tesekkurler. Bu elbetteki isimi gorur. Ancak ben bu fonksiyonu pekcok farki renk icin kullanacagim, ve her bir renk icin ayri bir fonksiyon tanimlayip farkli adlar koymayi pek istemiyorum.. Kisacasi bu olayi fonksiyon tanimi icinde, yani

Function Headcount(ShapeType As MsoAutoShapeType, Optional Target As Range) As Long

taniminin icinde tanimlanarak kullanimi mumkun olmaz mi?

 

[Ferhat Pazarçevirdi]

Neden olmasın, olur tabi ...

Aşağıdaki fonksiyonunu kullanınız.

Function Headcount(ShapeType As MsoAutoShapeType, [COLOR=red][B]Color As Integer[/B][/COLOR], Optional Target As Range) As Long
Dim sh As Worksheet, shp As Shape, cnt As Long
If Target Is Nothing Then
   For Each sh In ThisWorkbook.Sheets
       For Each shp In sh.Shapes
           If shp.Type = ShapeType Then
              If shp.Fill.ForeColor.SchemeColor = [COLOR=red][B]Color[/B][/COLOR] Then
                 cnt = cnt + 1
              End If
           End If
       Next
   Next
Else
   For Each shp In Target.Parent.Shapes
'       If shp.AutoShapeType = ShapeType Then
          If Not Intersect(shp.TopLeftCell, Target) Is Nothing _
             And Not Intersect(shp.BottomRightCell, Target) Is Nothing Then
              If shp.Fill.ForeColor.SchemeColor = [COLOR=red][B]Color [/B][/COLOR]Then
                 cnt = cnt + 1
              End If
          End If
'       End If
   Next
End If
Headcount = cnt
End Function

Kullanımı :
=headcount(1,A1:B10,10) ->A1:B10 aralığında kırmızı renkli yuvarlakları bulmak için