色を数えるためにVBAで作成された関数を編集する

Question

セルの色を数える関数を作成するコードを書きました。

Function CountCellsByColour(rData As Range, cellRefColor As Range) As Long 
    Dim indRefColor As Long 
    Dim cellCurrent As Range 
    Dim cntRes As Long 

    cntRes = 0 
    indRefColor = cellRefColor.Cells(1, 1).Interior.Color 
    cellPlusOne = cellCurrent + 1 
    For Each cellCurrent In rData 
     If (indRefColor = cellCurrent.Interior.Color) And (cellCurrent.EntireRow.Hidden = False) Then 
      cntRes = cntRes + 1 
     End If 
    Next cellCurrent 

    CountCellsByColour = cntRes 
End Function 

正常に機能しますが、色付きのセルが接触している場合は1だけカウントするように編集します。下の例では、関数がこの範囲の色の量を計算すると、6つの代わりに1つの緑と3つの赤が引かれます。これを可能に

EDIT：このような Example

Answer 1

は、私が持っているでしょう。この

Function CountCellsByColour(rData As Range, cellRefColor As Range) As Long 
    Dim indRefColor As Long, previousMatchingRow As Long 
    Dim cell As Range 
    Dim cntRes As Long 

    indRefColor = cellRefColor.Cells(1, 1).Interior.Color 
    previousMatchingRow = -1 '<--| initialize previous matching cell row so as not to be "recognized" at the first iteration 
    cntRes = 0 
    For Each cell In rData.SpecialCells(xlCellTypeVisible) '<--| loop through visible cells only 
     If indRefColor = cell.Interior.Color Then 
      If cell.Row > previousMatchingRow + 1 Then 
       cntRes = cntRes + 1 
       previousMatchingRow = cell.Row '<--| set previous matching cell row to the current matching cell 
      Else 
       previousMatchingRow = previousMatchingRow + 1 '<--| update previous matching cell row to the current "touching" cell 
      End If 
     End If 
    Next cell 

    CountCellsByColour = cntRes 
End Function 

Answer 2

何かが、おそらく最もエレガントではないが、中央のセルとして供給された範囲の引数を使用して、範囲を生成します。さらに先端を見てされるだろう-1 1つのループにコードを減らすために...

私は? CHECK_ADJACENTS(range("i5")).Addressを使用してチェックし、その結果$I$5,$J$4,$H$6

Function CHECK_ADJACENTS(rngInput As Excel.Range) As Excel.Range 

Dim lngCurrent As Long 

lngCurrent = rngInput.Interior.ColorIndex 

Set CHECK_ADJACENTS = rngInput 

On Error Resume Next 

    If rngInput.Offset(-1, -1).Interior.ColorIndex = lngCurrent Then 
     Set CHECK_ADJACENTS = Union(CHECK_ADJACENTS, rngInput.Offset(-1, -1)) 
    End If 

    If rngInput.Offset(-1, 0).Interior.ColorIndex = lngCurrent Then 
     Set CHECK_ADJACENTS = Union(CHECK_ADJACENTS, rngInput.Offset(-1, 0)) 
    End If 

    If rngInput.Offset(-1, 1).Interior.ColorIndex = lngCurrent Then 
     Set CHECK_ADJACENTS = Union(CHECK_ADJACENTS, rngInput.Offset(-1, 1)) 
    End If 

    If rngInput.Offset(0, -1).Interior.ColorIndex = lngCurrent Then 
     Set CHECK_ADJACENTS = Union(CHECK_ADJACENTS, rngInput.Offset(0, -1)) 
    End If 

    If rngInput.Offset(0, 1).Interior.ColorIndex = lngCurrent Then 
     Set CHECK_ADJACENTS = Union(CHECK_ADJACENTS, rngInput.Offset(0, 1)) 
    End If 

    If rngInput.Offset(1, -1).Interior.ColorIndex = lngCurrent Then 
     Set CHECK_ADJACENTS = Union(CHECK_ADJACENTS, rngInput.Offset(1, -1)) 
    End If 

    If rngInput.Offset(1, 0).Interior.ColorIndex = lngCurrent Then 
     Set CHECK_ADJACENTS = Union(CHECK_ADJACENTS, rngInput.Offset(1, 0)) 
    End If 

    If rngInput.Offset(1, 1).Interior.ColorIndex = lngCurrent Then 
     Set CHECK_ADJACENTS = Union(CHECK_ADJACENTS, rngInput.Offset(1, 1)) 
    End If 

    CHECK_ADJACENTS.Select 

End Function