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

mwinte10

New Member
Joined
Oct 22, 2010
Messages
6
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?

Code:
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
 

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
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.






Code:
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



Code:
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
 
Upvote 0
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

Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,531
Messages
6,114,172
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top