Combining VBA routines

[sparkytech]

I can't seem to figure out how to combine (2) VBA routines. I want both of them to run at the same time. My worksheet contains header rows for "Super Projects" and rows below are "Projects". This repeats through the worksheet:

Super Project (random color 1 in "A" through "Y")
Project (random color 1 only in "A")
Project (random color 1 only in "A")
Super Project (random color 2 in "A" through "Y")
Project (random color 2 only in "A")
Project (random color 2 only in "A")
Project (random color 2 only in "A")
etc.....

Logic:

1. Check if row contains "Super Project" in "Y" column. If Yes, goto 2
2. Check if row has fill color. If row is colored, skip to next row. If row has no fill color, goto 3.
3. Fill cells "A" through "Y" with unique random color. Then:
4. Fill "A" column the same color as above until next "Super Project" row. Then:
5. Repeat until all non-blank rows are colored
6. End

Here are the problems:

1. The sub "FormatSuperProjectHeadings" works, but colors the ENTIRE Super Project row, not just where there are non-blank cells. I need it to only fill the row where there is data (currently Columns "A" to "Y", and only if there is not a color in the row already. Right now, it will re-color the entire row every time.

2. The sub "ColorSideBar" works by itself, but needs to run immediately after the "FormatSuperProjectHeadings" sub. This routine will make the "A" cells color match the "Super Project" color above

I hope I explained this clearly. Any help would be greatly appreciated!

Sub FormatSuperProjectHeadings()

Dim r As Byte, g As Byte, b As Byte
Dim spcolor As Integer
Dim vR(), n As Integer

'Clear Cells
n = 3000
ReDim vR(1 To n)
For i = 1 To n
    Call GetUniqueNumbers
    r = myarr(0)
    g = myarr(1)
    b = myarr(2)
    vR(i) = RGB(r, g, b)
Next i
Application.ScreenUpdating = False
Dim MyCell As Range
With Sheets(1) 'Projects Sheet
    For Each MyCell In .Range("Y5:Y" & .Range("Y" & .Rows.Count).End(xlUp).Row)
        If MyCell = "Super Project" Then
            MyCell.EntireRow.Interior.Color = vR(WorksheetFunction.RandBetween(1, n))
            MyCell.Offset(, -22).Font.Bold = True
        End If
    Next
End With
Call ColorSideBar
Application.ScreenUpdating = True
End Sub

Sub ColorSideBar()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Projects")
Dim MyCell2 As Range
For Each MyCell2 In ws.Range("A2:A" & ws.Range("A" & ws.Rows.Count).End(xlUp).Row)
    If MyCell2.Interior.ColorIndex = xlNone Then
        If MyCell2.Offset(-1).Interior.ColorIndex <> xlNone Then
            MyCell2.Interior.Color = MyCell2.Offset(-1).Interior.Color
        End If
    End If
Next MyCell2
End Sub

Sub GetUniqueNumbers()

Dim i As Long, j As Long
Dim allset As Boolean
ReDim myarr(0 To 2) 'Change array size here
For i = 0 To UBound(myarr)
    Do
        myarr(i) = WorksheetFunction.RandBetween(128, 255) 'Change number range here
        For j = 0 To UBound(myarr)
            If i <> j Then
                If myarr(i) = myarr(j) Then
                    Exit For
                Else
                    If j = UBound(myarr) Then
                        allset = True
                    End If
                End If
            End If
            If j = UBound(myarr) Then
                allset = True
            End If
        Next j
    Loop Until allset = True
    allset = False
Next i
End Sub

 

[=ODIN=]

Re: Need help combining VBA routines

I marked all the row i changed or added with a 'added comment. I think this will take care of request 1. Not sure why request 2 isn't happening already since you have the line "Call ColorSideBar" at the bottom -- that should run the macro i think.

Sub FormatSuperProjectHeadings()

Dim r As Byte, g As Byte, b As Byte
Dim spcolor As Integer
Dim vR(), n As Integer

'Clear Cells
n = 3000
ReDim vR(1 To n)
For i = 1 To n
    Call GetUniqueNumbers
    r = myarr(0)
    g = myarr(1)
    b = myarr(2)
    vR(i) = RGB(r, g, b)
Next i
Application.ScreenUpdating = False
Dim MyCell As Range
With Sheets(1) 'Projects Sheet
    dim theColor 'added
     theColor = vR(WorksheetFunction.RandBetween(1, n)) 'added

    For Each MyCell In .Range("Y5:Y" & .Range("Y" & .Rows.Count).End(xlUp).Row)
        If MyCell = "Super Project" Then 'added
            if mycell.interior.color <> 16777215 and mycell.value <> "" then 'added
                 MyCell.Interior.Color = theColor 'added
                 MyCell.Font.Bold = True 'added
            end if 'added
        End If
    Next
End With
Call ColorSideBar
Application.ScreenUpdating = True
End Sub

 

[sparkytech]

Re: Need help combining VBA routines

Thanks for the help and quick reply! I tweaked it slightly and got it working. Now, the only problem I am having is this: I copied the same routine to a new one, and want to eliminate the check for existing cell color, so it recolors all of the cells no matter what. When I try to do that, it only recolors the "Super Project" headings, and not the "A" column.

In other words, one routine recolors everything, and one routine colors only cells without color. Any ideas?

Sub FormatSuperProjectHeadings()

Dim r As Byte, g As Byte, b As Byte
Dim spcolor As Integer
Dim vR(), n As Integer

'Clear Cells
n = 3000
ReDim vR(1 To n)
For i = 1 To n
    Call GetUniqueNumbers
    r = myarr(0)
    g = myarr(1)
    b = myarr(2)
    vR(i) = RGB(r, g, b)
Next i
Application.ScreenUpdating = False
Dim MyCell As Range
With Sheets(1) 'Projects Sheet
    For Each MyCell In .Range("Y5:Y" & .Range("Y" & .Rows.Count).End(xlUp).Row)
        If MyCell = "Super Project" Then
            If MyCell.Interior.ColorIndex = xlNone Then 'added
                Range("A" & MyCell.Row & ":Y" & MyCell.Row).Interior.Color = vR(WorksheetFunction.RandBetween(1, n))
                MyCell.Offset(, -22).Font.Bold = True
            End If
        End If
    Next
End With
Call ColorSideBar
Application.ScreenUpdating = True
End Sub
Sub GetUniqueNumbers()
Dim i As Long, j As Long
Dim allset As Boolean
ReDim myarr(0 To 2) 'Change array size here
For i = 0 To UBound(myarr)
    Do
        myarr(i) = WorksheetFunction.RandBetween(127, 255) 'Change number range here
        For j = 0 To UBound(myarr)
            If i <> j Then
                If myarr(i) = myarr(j) Then
                    Exit For
                Else
                    If j = UBound(myarr) Then
                        allset = True
                    End If
                End If
            End If
            If j = UBound(myarr) Then
                allset = True
            End If
        Next j
    Loop Until allset = True
    allset = False
Next i
End Sub