Excel表格间隔填充颜色（VBA)

这个纯粹是自用排版的，为了设置指定的单元格区域按照按指定颜色间隔填充，增加表格的可读性。如下图这样。

功能构思：
1）编写一段宏代码，在工具栏生成一个按钮，点击运行。
2）用一个窗体（模式设为0，确保窗体运行的时候同时可以操作工作表），三个按钮，按钮1选择第一种颜色，按钮2选择第二种颜色，按钮3执行，按钮1~2选择颜色的时候边上文本上自动显示对应的颜色。
3）同时支持自定义颜色&H开头的样式。

界面样式：

代码：

'主界面代码
Sub bg2color()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
 uf1.Show 0 '弹出窗体uf1
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

'下面是窗体代码，写入uf1中
'声明全局变量，在窗体中按钮3中调用
Dim th1, bg1, shd1, pco1, pat1, pshd1
Dim th2, bg2, shd2, pco2, pat2, pshd2

'按钮1代码，获取活动单元格背景作为背景A
'如果直接用excel工具栏的内置颜色，这里面有更多附加信息，如淡色，如图案阴影等，要全部获取，要不然颜色有不一样的地方。
'如果是手动&HC0C0C0这样的，则这些附加信息就无效了。
'excel自带颜色属于主题色，不光只有colorindex信息。

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

uf1.TextBox1.BackColor = ActiveCell.Interior.Color
uf1.TextBox1.Text = "索引:" & ActiveCell.Interior.ColorIndex & "|淡色" & Format(ActiveCell.Interior.TintAndShade, "0%")
        
th1 = ActiveCell.Interior.ThemeColor
shd1 = ActiveCell.Interior.TintAndShade
pco1 = ActiveCell.Interior.PatternColorIndex
pat1 = ActiveCell.Interior.Pattern
pshd1 = ActiveCell.Interior.PatternTintAndShade

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

'按钮2代码，获取活动单元格背景作为背景B
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

uf1.TextBox2.BackColor = ActiveCell.Interior.Color
uf1.TextBox2.Text = "索引:" & ActiveCell.Interior.ColorIndex & "|淡色" & Format(ActiveCell.Interior.TintAndShade, "0%")

th2 = ActiveCell.Interior.ThemeColor
shd2 = ActiveCell.Interior.TintAndShade
pco2 = ActiveCell.Interior.PatternColorIndex
pat2 = ActiveCell.Interior.Pattern
pshd2 = ActiveCell.Interior.PatternTintAndShade

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

'按钮3代码，执行
'执行3之前需要选择超过2行以上的单元格，否则会提示退出。
'因为小于2行的这个操作没有意义。

Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
   
    Dim rows_count As Integer
    Dim rows_id As Integer
    Dim column_count As Integer
    Dim column_id As Integer
    
    column_count = Selection.Columns.Count '返回选择区域列数
    rows_id = ActiveCell.Row  '返回活动单元格的行号
    rows_count = Selection.Rows.Count  '返回选择区域的行数
    column_id = ActiveCell.Column  '返回活动单元格的列号
    linea = 0
    
    If rows_count < 2 Then
      MsgBox "选择总行数小于两行，无法启用功能"
      Application.Calculation = xlCalculationAutomatic
      Application.ScreenUpdating = True
      Exit Sub
    End If
 
     bga = ""

        For i = 0 To rows_count - 1
            linea = linea + 1
            clinea = linea Mod 2 '取奇偶行
            
            If clinea = 0 Then
                If Left(TextBox1.Text, 2) = "&H" Then
                bga = Left(TextBox1.Text, 8)
                Else
                bga = ""  '这里要重置，要不然bga有可能保持另一个条件的值
                End If
                
                tha = th1
                shda = shd1
                pcoa = pco1
                pata = pat1
                pshda = pshd1
                
            Else
                If Left(TextBox2.Text, 2) = "&H" Then
                bga = Left(TextBox2.Text, 8)
                Else
                bga = ""  '这里要重置，要不然bga有可能保持另一个条件的值
                End If
                
                tha = th2
                shda = shd2
                pcoa = pco2
                pata = pat2
                pshda = pshd2
            End If
            
            With Range(Cells(rows_id + i, column_id), Cells(rows_id + i, column_id + column_count - 1)).Interior
                .Pattern = pata
                .PatternColorIndex = pcoa
                .ThemeColor = tha
                .TintAndShade = shda
                .PatternTintAndShade = pshda
                If bga <> "" Then .Color = bga '这里加个判断自定义色
            End With
     
        Next i

'该行为增加选择单元格内外框线
Range(Cells(rows_id, column_id), Cells(rows_id + rows_count - 1, column_id + column_count - 1)).Borders.LineStyle = 1

uf1.Hide
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

操作方法

将上述代码添加到模块后（窗体控件对应生成）
将文件保存为xlam文件，excel中加载项加载该文件。
工具栏中添加自定义按钮，选择宏 bgcolor2，按钮随意，没工夫做。
先在任意两个单元格设置背景，分别选中单元格，点击按钮1或者2，获取背景信息。
两个背景都设置好之后（也可以直接在文本框中设置 &HCCBBCC 这样的自定义颜色），这时候选择要设置的单元格区域，比如A2:G20，点击确定，就会自动隔行填充了。

最新文章

标签