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判断的一个分支。正文完

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