【原】Excel VBA 根据单元格颜色提取号段

快速浏览

往期合集：【2023年3月】【2023年4月】【2023年5月】【2023年6月】【2023年7月】

实用案例

|收费管理系统|中医诊所收费系统|

|日期控件|简单的收发存|

|电子发票管理助手|Excel表格拆分神器|

|Excel多种类型文件合并|

收费使用项目

|财务管理系统|

内容提要

• 根据标色的单元格提取号段

大家好，我是冷水泡茶，今天在论坛上看到一个求助贴：

数据及要求是这样的：

在我发完回帖，浏览帖子的时候，发现楼主又有新的需求：

只列出标色的号段，略一思索，把代码中未标色生成号段的代码删去，运行一下，完美！

废话不多说，我们一起来看一下：

我们再来看一下代码：

提取所有号段代码

Sub Extract()    Dim arrData()    Dim lastRow As Integer    Dim ws As Worksheet    Set ws = ThisWorkbook.Sheets("Sheet1")    lastRow = ws.UsedRange.Rows.Count    arrData = ws.Range("A1:C" & lastRow).Value    For i = 2 To lastRow        arrData(i, 3) = Cells(i, 1).Interior.ColorIndex        arrData(i, 2) = ""    Next    t = 2    For i = 2 To lastRow - 1        If arrData(i, 3) = -4142 Then            If arrData(i, 1) <> "" Then arrData(t, 2) = arrData(i, 1) & "--" & arrData(i, 1)                t = t + 1            End If        Else            If arrData(i - 1, 3) = -4142 Then                m = i            ElseIf arrData(i + 1, 3) = -4142 Then                arrData(t, 2) = arrData(m, 1) & "--" & arrData(i, 1)                t = t + 1            End If  End If    Next    If arrData(lastRow, 3) = -4142 Then        arrData(t, 2) = arrData(i, 1) & "--" & arrData(i, 1)    Else        arrData(t, 2) = arrData(m, 1) & "--" & arrData(lastRow, 1)    End If    ws.Range("B2:B" & lastRow).NumberFormat = "@"    ws.Range("A1").Resize(lastRow - 1, 2) = arrDataEnd Sub

代码解析：

1、把数据读入数组，我还是习惯用数组，其实本案可以直接操作单元格，比数组方便。

2、数组为n行3列的数组，通过循环把第二列清空，准备填写取号结果，第三列存入第一列对应单元格的颜色值。

3、计数器变量t=2，每生成一个号段加上1，顺序写入数组的第二列。

4、通过判断第三列颜色值，是否是无颜色（-4142），如果有颜色，其前后是否是无颜色，来确定标色的范围，生成号段。

5、这里循环到最后第二行，因为要判断i+1，会报错。

6、最后判断一下最后一行有无标色，生成最后一个号段。

7、把数组写入单元格，这里我们只需要第一、第二列，我们从“A1”单元格扩展2列。

提取标色号段代码

Sub Extract2()    Dim arrData()    Dim lastRow As Integer    Dim ws As Worksheet    Set ws = ThisWorkbook.Sheets("Sheet1")    lastRow = ws.UsedRange.Rows.Count    arrData = ws.Range("A1:C" & lastRow).Value    For i = 2 To lastRow        arrData(i, 3) = Cells(i, 1).Interior.ColorIndex        arrData(i, 2) = ""    Next    t = 2    For i = 2 To lastRow - 1        If arrData(i, 3) <> -4142 Then   If arrData(i - 1, 3) = -4142 Then                m = i            ElseIf arrData(i + 1, 3) = -4142 Then                arrData(t, 2) = arrData(m, 1) & "--" & arrData(i, 1)                t = t + 1            End If         End If    Next    If arrData(lastRow, 3) <> -4142 Then  arrData(t, 2) = arrData(m, 1) & "--" & arrData(lastRow, 1)    End If    ws.Range("B2:B" & lastRow).NumberFormat = "@"    ws.Range("A1").Resize(lastRow - 1, 2) = arrDataEnd Sub

代码解析：

在“提取所有号段”的基础上，把生成未标色号段的代码删除，也就是删除了IF判断的一个分支。

正文完

喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！