Cycle Accent Backgrounds in Excel

CycleAccentBackgrounds.bas

' OMNI
' Author: Andre Terra
' Name: CycleAccentBackgrounds
' URL: https://gist.github.com/airstrike/11f58afb9b44c2c81291
' Version: 1.2.1

Sub CycleAccentBackground()
    Dim NextColor As Integer
    Dim NextColorRGB As Long
    Dim ThemeColor As Long
    Dim SelectionFont As Long
    ThemeColor = Selection.Cells(1, 1).Interior.ThemeColor
    NextColor = ThemeColor + 1
    
    
    For Each cell In Selection
        With cell.Interior
            SelectionFont = GetFontColor(cell.Font)
            If ThemeColor = xlThemeColorAccent6 Then
                'Reset to no background, automatic foreground
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
                
                If SelectionFont = xlThemeColorDark1 Or _
                   SelectionFont = xlThemeColorLight1 Or _
                   SelectionFont = xlAutomatic Then _
                    Selection.Font.ColorIndex = xlAutomatic
                    Selection.Font.TintAndShade = 0
                
            Else
                If .ThemeColor = -4142 Then 'If no fill
                    NextColor = xlThemeColorAccent1
                End If
                
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .ThemeColor = NextColor
            
                
                If SelectionFont = xlThemeColorDark1 Or _
                   SelectionFont = xlThemeColorLight1 Or _
                   SelectionFont = xlAutomatic Then
                   
                    .Parent.Font.ThemeColor = xlThemeColorLight1
                    NextColorRGB = ActiveWorkbook.Theme.ThemeColorScheme.Colors(NextColor)
                   
                    If (NextColorRGB Mod 256) + (NextColorRGB \ 256 Mod 256) + (NextColorRGB \ 256 ^ 2 Mod 256) < 383 Then _
                        Selection.Font.ThemeColor = xlThemeColorDark1
                        
                End If
            
            
            End If
        End With
    
    Next
    
End Sub

Function GetFontColor(ByRef F As Font) As Long
    Dim color As Long
    
TryThemeColor:
    On Error GoTo NotThemeColor
    color = Selection.Font.ThemeColor
    GoTo ExitSub
    
NotThemeColor:
    color = Selection.Font.ColorIndex
    GoTo ExitSub
    
ExitSub:
    GetFontColor = color
    
End Function