如何编写生成如图所示彩色方块的VBA函数？现有代码有误

我需要编写一个生成指定样式彩色方块的VBA函数，尝试了以下代码但结果不符合预期：

Sub GenererCarreCouleur()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1) ' Changez le numéro de feuille si nécessaire
    
    Dim rng As Range
    Set rng = ws.Range("A1:G8")
    
    Dim i As Integer, j As Integer, count As Integer
    count = 1
    
    For i = 1 To 8
        For j = 1 To 7
            rng.Cells(i, j).Value = count
            rng.Cells(i, j).Interior.Color = GetCouleur(count)
            count = count + 1
        Next j
    Next i
End Sub

Function GetCouleur(ByVal valeur As Integer) As Long
    ' Ajoutez autant de cas que nécessaire pour couvrir toutes les valeurs jusqu'à 56
    Select Case valeur
        Case 1 To 7
            GetCouleur = RGB(0, 0, 0) ' Noir
        Case 8 To 14
            GetCouleur = RGB(255, 255, 255) ' Blanc
        Case 15 To 21
            GetCouleur = RGB(255, 0, 0) ' Rouge
        ' Ajoutez d'autres cas ici en fonction de vos besoins
        Case Else
            GetCouleur = RGB(0, 0, 0) ' Noir par défaut
    End Select
End Function

问题分析 #

原代码通过递增的count值判断颜色，逻辑上是每7个单元格一组颜色，但实际需要的是每行7个单元格统一颜色，共8行对应8种不同颜色。此外原代码未补充完整所有8种颜色的定义。

修正后的代码 #

Sub GenererCarreCouleur()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets(1) ' 根据需要修改工作表编号
    
    Dim rng As Range
    Set rng = ws.Range("A1:G8")
    
    Dim i As Integer, j As Integer
    ' 清空目标区域原有格式和内容
    rng.Clear
    
    For i = 1 To 8
        For j = 1 To 7
            ' 可选：设置单元格显示行号，不需要可注释此行
            rng.Cells(i, j).Value = i
            ' 根据行号匹配对应颜色
            rng.Cells(i, j).Interior.Color = GetCouleur(i)
        Next j
    Next i
End Sub

Function GetCouleur(ByVal ligne As Integer) As Long
    ' 为8行分别定义不同颜色
    Select Case ligne
        Case 1
            GetCouleur = RGB(0, 0, 0) ' 黑色
        Case 2
            GetCouleur = RGB(255, 255, 255) ' 白色
            ' 白色单元格设置黑色字体，避免内容不可见
            ThisWorkbook.Sheets(1).Range("A" & ligne & ":G" & ligne).Font.Color = RGB(0, 0, 0)
        Case 3
            GetCouleur = RGB(255, 0, 0) ' 红色
        Case 4
            GetCouleur = RGB(0, 255, 0) ' 绿色
        Case 5
            GetCouleur = RGB(0, 0, 255) ' 蓝色
        Case 6
            GetCouleur = RGB(255, 255, 0) ' 黄色
        Case 7
            GetCouleur = RGB(255, 0, 255) ' 洋红
        Case 8
            GetCouleur = RGB(0, 255, 255) ' 青色
        Case Else
            GetCouleur = RGB(128, 128, 128) ' 灰色默认值
    End Select
End Function

修正说明 #

1. 移除count变量，直接用行号i匹配颜色，确保每行所有单元格颜色一致
2. 补充完整8种颜色的定义，覆盖全部8行
3. 针对白色行单独设置黑色字体，解决内容不可见的问题
4. 新增rng.Clear清空目标区域，确保生成的效果不受原有内容/格式影响

内容的提问来源于stack exchange，提问作者user22884379