VBA insert variable number of rows based on yellow cells in single row

[mwinte10]

Hello All,

The code I have written is intended to insert a variable number of rows underneath(or above) each existing row based on the number of yellow cells. I have borrowed Functions from cpearson.com to count the number of colored cells in a range.

I keep getting stuck on the line that is supposed to insert the rows. Does anybody have any ideas?

Sub Insertrow()
Dim i As Long
Dim insertnumber As Long
 
For i = 4433 To 2 Step -1
 
    insertnumber = CountColor(InRange:=Cells(i, 28), ColorIndex:=6)
 
    Rows(i).Select
    Selection.Resize(insertnumber).EntireRow.Insert
 
 
Next i
 
End Sub

I have not included the code for the Function CountColor but I can if it would be helpful.

Thanks

Mark

 

[mwinte10]

I actually think that the way that I am using the Function may be wrong, because if I replace "insertnumber" with the number 10, the routine works.

Function CountColor(InRange As Range, ColorIndex As Long, _
    Optional OfText As Boolean = False) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' CountColor
' This function counts the cells in InRange whose ColorIndex
' is equal to the ColorIndex parameter. The ColorIndex of the
' Font is tested if OfText is True, or the Interior property
' if OfText is omitted or False. If ColorIndex is not a valid
' ColorIndex (1 -> 56, xlColorIndexNone, xlColorIndexAutomatic)
' 0 is returned. If ColorIndex is 0, then xlColorIndexNone is
' used if OfText is Fasle or xlColorIndexAutomatic if OfText
' is True. This allows the caller to use a value of 0 to indicate
' no color for either the Interior or the Font.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim R As Range
Dim N As Long
Dim CI As Long
If ColorIndex = 0 Then
    If OfText = False Then
        CI = xlColorIndexNone
    Else
        CI = xlColorIndexAutomatic
    End If
Else
    CI = ColorIndex
End If
 
Application.Volatile True
Select Case ColorIndex
    Case 0, xlColorIndexNone, xlColorIndexAutomatic
        ' OK
    Case Else
        If IsValidColorIndex(ColorIndex) = False Then
        'If ColorIndex(ColorIndex) = False Then
        CountColor = 0
        Exit Function
        End If
End Select
For Each R In InRange.Cells
    If OfText = True Then
        If R.Font.ColorIndex = CI Then
            N = N + 1
        End If
    Else
        If R.Interior.ColorIndex = CI Then
            N = N + 1
        End If
    End If
Next R
CountColor = N
End Function

Private Function IsValidColorIndex(ColorIndex As Long) As Boolean
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' IsValidColorIndex
' This returns TRUE if ColorIndex is between 1 and 56 or equal
' to either xlColorIndexNone or xlColorIndexAutomatic. It
' returns FALSE otherwise.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Select Case ColorIndex
    Case 1 To 56, xlColorIndexNone, xlColorIndexAutomatic
        IsValidColorIndex = True
    Case Else
        IsValidColorIndex = False
End Select
End Function

Thanks again.

Mark

 

[mwinte10]

In case anybody ever wants to do this, here is the code that works. Must be used in conjunction with the above formulas.

Thanks.

Mark

Sub Insert2()
 
Application.ScreenUpdating = False
 
Dim i As Long
Dim LR As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
 
For i = LR To 2 Step -1
 
Dim cc As Long
 
    cc = CountColor(InRange:=Range(Cells(i, 1), Cells(i, 28)),ColorIndex:=6)
    Cells(i, 1).Resize(cc).EntireRow.Insert
 
Next
 
Dim LR2 As Long
LR2 = Range("A" & Rows.Count).End(xlUp).Row
 
For i = LR2 To 2 Step -1
 
    If Cells(i, 1) = "" Then
    Rows(i).Interior.ColorIndex = 0
    End If
 
Next
 
Application.ScreenUpdating = True
End Sub