用于交替组行的颜色的宏

Question

我正在尝试编写一个VBA宏来为Excel工作表中的前8行着色，然后将下一个8保留为未着色，然后再将颜色保留为8 - 依此类推直到工作表的末尾。

到目前为止，我有以下代码：

Sub ColorInGroups()

Dim k As Long
k = 1

For i = k To k + 7
     Rows(i).Interior.Color = RGB(200, 200, 200)
Next i

End Sub

Answer 1

如果您希望将其作为宏，则可以执行以下操作：

Sub ColorInGroups()

Dim i As Long, w As Long

w = 8 ' Number of rows each time

For i = 1 To 50 * w Step w * 2           ' 50 will produce 50 groups of rows, increase/decrease as you like
    Range(Cells(i, 1), Cells(i + w - 1, 1)).EntireRow.Interior.Color = RGB(200, 200, 200)
Next i

End Sub

Answer 2

在下面的代码中尝试使用公式，它将为前8行着色，然后不为下一个8着色，然后着色，依此类推......

注意：您可以将参数GroupSize更改为每次想要着色的行数。

<强> 代码

Option Explicit

Sub ColorInGroups()

Dim k As Long, i As Long, LastRow As Long
Dim GroupSize As Long

k = 1
LastRow = 100
GroupSize = 8

For i = k To k + LastRow
    ' mathematical formula I used to get the result wanted
    If Round((i / GroupSize) + 0.5) Mod 2 <> 0 Then


    ' ***** mathematical formula (for flexible first row) *****
    'If (Application.WorksheetFunction.Floor(((i - k) / GroupSize), 1) + 1) Mod 2 = 0 Then
        Rows(i).Interior.Color = RGB(200, 200, 200)
    End If
Next i

End Sub      

Answer 3

此方法不假设第一行是第1行，并且使用非常简单的语法。

Sub ColorInGroups()
    ' Declare variables for which rows to colour, and what the block size should be
    Dim firstrow As Long: firstrow = 5
    Dim lastrow As Long: lastrow = 35
    Dim groupsize As Long: groupsize = 8
    ' Loop over the rows chosen, and colour as desired
    Dim i As Long
    For i = firstrow To lastrow
        ' Check if i is within an "even" multiple block of groupsize
        If (i - firstrow) Mod groupsize * 2 >= groupsize Then
            Rows(i).Interior.Color = RGB(200, 200, 200)
        End If
    Next i
End Sub

更灵活的选择是将范围传递给sub，以及块大小。对于不在灰色块中的单元格，还将颜色重置为无意味着您可以重新运行此子项，而无需先手动删除颜色。

Sub ColorInGroups(rng As Range, groupsize As Long)
    Dim firstrow As Long: firstrow = rng.Cells(1).Row
    Dim lastrow As Long: lastrow = rng.Cells(rng.Cells.Count).Row
    Dim i As Long
    For i = firstrow To lastrow
        ' Check if i is within an "even" multiple block of groupsize
        If (i - firstrow) Mod groupsize * 2 >= groupsize Then
            Rows(i).Interior.Color = RGB(200, 200, 200)
        Else
            Rows(i).Interior.Color = xlNone
        End If
    Next i
End Sub

用法：

' Pass in a range object and some integer
ColorInGroups ActiveSheet.UsedRange, 8

最后，使用

可以加快速度

Sub ColorInGroups()
    Application.ScreenUpdating = False
    ' ... sub code as above ...
    Application.ScreenUpdating = True
End Sub

Answer 4

正如@CodeConfident在评论中提到的，你可以使用公式和条件格式。

整行有两种条件格式，使用公式确定要格式化的单元格：
这个公式（其他公式可用，可能更有效）：
=MOD(INT((ROW()-1)/8),2)=0和=MOD(INT((ROW()-1)/8),2)=1

然后可以使用 Format Painter 将格式复制下来，无论你需要多少行。

Answer 5

条件格式化将改善文件大小，提高工作簿的速度和效率。

Cells.FormatConditions.Add Type:=xlExpression, Formula1:="=MOD(ROW(),16)<8"
With Cells.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
    .Color = RGB(200, 200, 200)
    .TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False

创建大量格式化块的问题是Excel必须为每个块创建一个xml节点来描述格式。

将格式应用于各行后，请注意文件大小的差异。

Excel文件是Zip文件夹。通过将Workbook的扩展名重命名为Zip，您可以查看Worksheet的xml。注意如何为每行的格式添加节点。

Sub CalculateRunTime_Seconds()
'PURPOSE: Determine how many seconds it took for code to completely run
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

    Dim StartTime As Double
    Dim SecondsElapsed As Double
    Dim FileLength As Long

    'Remember time when macro starts
    StartTime = Timer

    '*****************************
    FileLength = FileLen(ThisWorkbook.FullName)

    ApplyRowBanding

    '*****************************

    'Determine how many seconds code took to run
    SecondsElapsed = Round(Timer - StartTime, 2)

    'Notify user in seconds
    Debug.Print "This code ran successfully in " & SecondsElapsed & " seconds"

    Debug.Print "File Size Before Formatting:", FileLength

    ThisWorkbook.Save

    Debug.Print "File Size After Formatting:", FileLen(ThisWorkbook.FullName)

    Debug.Print "Difference in File Size:", FileLen(ThisWorkbook.FullName) - FileLength
End Sub

Sub ApplyRowBanding()
    Application.ScreenUpdating = False
    Dim x As Long
    Dim lastRow As Long
    For x = 1 To Rows.Count Step 16
        lastRow = IIf(x + 8 < Rows.Count, x + 7, Rows.Count - x)
        Rows(x & ":" & lastRow).Interior.Color = RGB(200, 200, 200)
    Next

    Application.ScreenUpdating = True
End Sub