实例需求：数据表如下图所示，现需要根据规则，在符合要求的单元格上，添加连线。
- 连续单元格位于对角线方向
- 单元格内容相同
- 连续单元格数量不少于7个
示例代码如下。
Sub LT2RB()Dim objDic As Object, rngData As Range, bFlag As BooleanDim i As Long, j As Long, r As Long, c As Long, sKey As StringDim arrData, RowCnt As Long, ColCnt As Long, iCount As LongDim oSht1 As Worksheet, oSht2 As WorksheetDim sCell As Range, eCell As RangeConst S_ROW = 5Const S_COL = 2Set rngData = Cells(S_ROW, S_COL).CurrentRegionarrData = rngData.ValueRowCnt = UBound(arrData)ColCnt = UBound(arrData, 2)For i = 1 To ColCntFor j = 1 To RowCntbFlag = FalseIf i = 1 Or j = 1 ThenbFlag = TrueElser = j - 1: c = i - 1If r < 1 Then r = 1If c < 1 Then c = 1If Not arrData(j, i) = arrData(r, c) Then bFlag = TrueEnd IfIf bFlag ThensKey = arrData(j, i)iCount = 0: r = j: c = iSet sCell = Cells(S_ROW + r - 1, S_COL + c - 1)DoIf sKey = arrData(r, c) TheniCount = iCount + 1Set eCell = Cells(S_ROW + r - 1, S_COL + c - 1)ElseIf iCount > 6 ThenDebug.Print sCell.Address, eCell.AddressAddLine sCell, eCellEnd IfiCount = 1sKey = arrData(r, c)Set sCell = Cells(S_ROW + r - 1, S_COL + c - 1)End Ifr = r + 1: c = c + 1Loop Until r = RowCnt + 1 Or c = ColCnt + 1If iCount > 6 ThenDebug.Print sCell.Address, eCell.AddressAddLine sCell, eCellEnd IfEnd IfNext jNext i
End Sub
【代码解析】
LT2RB代码过程实现左上到右下的数据查找。
第7~8行代码定义数据表格的起始行和列。
第9行代码获取数据表区域。
第10行代码将数据表加载到数组中。
第11~12行代码获取数据表的行数和列数。
第13~14行代码循环遍历数据表中每个单元格。
第15行代码初始化标志变量bFlag。
第16行代码判断是否为首行或者首列单元格。
如果满足条件，第17行代码设置bFlag为True，否则行和列减一，即arrData(r, c)和arrData(j, i) 为对角线上相邻的两个单元格，如果二者不等，第22行设置bFlag为True。
如果bFlag至为True，arrData(j, i)与其左上相邻单元格内容不同，那么将开始一个新的查找。
第25行代码将查找值保存到变量sKey中。
第26行代码初始化变量。
第27行代码将线条的起始单元格保存在变量sCell中。
第28~42行代码循环查找对角线的单元格。
第29行代码判断对角线上相邻单元格是否相同。
如果二者相同，第30行代码计数器累加一，第31行代码将线条的结束单元格保存在变量eCell中。
如果二者不同，第33行代码判断当前的计数器是否满足条件（至少7个）。
如果满足条件，第35行代码将调用AddLine添加线条。
如果不满足，第37行代码将计数器重置为1，第38行代码跟新查找值，第40行代码更新线条起始单元格，开始新的一次查找。
第41行代码行号和列号递增一。
第42行代码循环退出条件为行或者列超出数据表范围。
第4346行代码与第3336行代码相同，不再赘述。
Sub LB2RT()Dim objDic As Object, rngData As Range, bFlag As BooleanDim i As Long, j As Long, r As Long, c As Long, sKey As StringDim arrData, RowCnt As Long, ColCnt As Long, iCount As LongDim oSht1 As Worksheet, oSht2 As WorksheetDim sCell As Range, eCell As RangeConst S_ROW = 5Const S_COL = 2Set rngData = Cells(S_ROW, S_COL).CurrentRegionarrData = rngData.ValueRowCnt = UBound(arrData)ColCnt = UBound(arrData, 2)For i = 1 To ColCntFor j = 5 To RowCntbFlag = FalseIf i = 1 Or j = RowCnt ThenbFlag = TrueElser = j + 1: c = i - 1If r > RowCnt Then r = RowCntIf c < 1 Then c = 1If Not arrData(j, i) = arrData(r, c) Then bFlag = TrueEnd IfIf bFlag ThensKey = arrData(j, i)iCount = 0: r = j: c = iSet sCell = Cells(S_ROW + r - 1, S_COL + c - 1)DoIf sKey = arrData(r, c) TheniCount = iCount + 1Set eCell = Cells(S_ROW + r - 1, S_COL + c - 1)ElseIf iCount > 6 ThenDebug.Print sCell.Address, eCell.AddressAddLine sCell, eCellEnd IfiCount = 1sKey = arrData(r, c)Set sCell = Cells(S_ROW + r - 1, S_COL + c - 1)End Ifr = r - 1: c = c + 1Loop Until r = 0 Or c = ColCnt + 1If iCount > 6 ThenDebug.Print sCell.Address, eCell.AddressAddLine sCell, eCellEnd IfEnd IfNext jNext i
End Sub
【代码解析】
LB2RT代码过程实现左下到右上的数据查找，其原理与LT2RB类似。
Sub Main()ActiveSheet.DrawingObjects.DeleteLT2RBLB2RT
End Sub
Sub AddLine(s As Range, e As Range)ActiveSheet.Shapes.AddConnector(msoConnectorStraight, _s.Left + s.Width / 2, s.Top + s.Height / 2, _e.Left + e.Width / 2, e.Top + e.Height / 2).SelectWith Selection.ShapeRange.Line.Visible = msoTrue.Weight = 2End With
End Sub
【代码解析】
第2行代码清除工作表中的全部线条。
第3~4行代码分别调用两个Sub过程查找对角线数据。
第6~14行代码用于条件线条。
第7~9行代码添加一个线条对象，并选中该对象。
第11行代码设置线条对象可见。
第11行代码设置线条粗度为2。
