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
 

mwinte10

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

mwinte10

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

Forum statistics

Threads
1,081,690
Messages
5,360,614
Members
400,592
Latest member
badgergurl

Some videos you may like

This Week's Hot Topics

  • VBA (Userform)
    Hi All, I just would like to know why my code isn't working. Here is my VBA code: [CODE=vba]Private Sub OKButton_Click() Dim i As Integer...
  • List box that changes fill color
    Hello, I have gone through so many pages trying to figure this out. I have a 2020 calendar that depending on the day needs to have a certain...
  • Remove duplicates and retain one. Cross-linked cases
    Hi all I ran out of google keywords to use and still couldn't find a reference how to achieve the results of a single count. It would be great if...
  • VBA Copy and Paste With Duplicates
    Hello All, I'm in need of some input. My VBA skills are sub-par at best. I've assembled this code from basic research and it works but is...
  • Macro
    is it possible for a macro to run if the active cell value is different to the value above it
  • IF DATE and TIME
    I currently use this to check if date has passed but i also need to set a time on it too. Is it possible? [CODE=vba]=IF(B:B>TODAY(),"Not...
Top