本文于2023年8月5日首发于本人同名公众号：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判断的一个分支。
喜欢就点个赞、点在看、留个言呗！分享一下更给力！感谢！