Excel数据检视——对角线连续数据连线
实例需求：数据表如下图所示，现需要根据规则，在符合要求的单元格上，添加连线。
- 连续单元格位于对角线方向
- 单元格内容相同
- 连续单元格数量不少于7个
示例代码如下。
Sub LT2RB()
Dim objDic As Object, rngData As Range, bFlag As Boolean
Dim i As Long, j As Long, r As Long, c As Long, sKey As String
Dim arrData, RowCnt As Long, ColCnt As Long, iCount As Long
Dim oSht1 As Worksheet, oSht2 As Worksheet
Dim sCell As Range, eCell As Range
Const S_ROW = 5
Const S_COL = 2
Set rngData = Cells(S_ROW, S_COL).CurrentRegion
arrData = rngData.Value
RowCnt = UBound(arrData)
ColCnt = UBound(arrData, 2)
For i = 1 To ColCnt
For j = 1 To RowCnt
bFlag = False
If i = 1 Or j = 1 Then
bFlag = True
Else
r = j - 1: c = i - 1
If r < 1 Then r = 1
If c < 1 Then c = 1
If Not arrData(j, i) = arrData(r, c) Then bFlag = True
End If
If bFlag Then
sKey = arrData(j, i)
iCount = 0: r = j: c = i
Set sCell = Cells(S_ROW + r - 1, S_COL + c - 1)
Do
If sKey = arrData(r, c) Then
iCount = iCount + 1
Set eCell = Cells(S_ROW + r - 1, S_COL + c - 1)
Else
If iCount > 6 Then
Debug.Print sCell.Address, eCell.Address
AddLine sCell, eCell
End If
iCount = 1
sKey = arrData(r, c)
Set sCell = Cells(S_ROW + r - 1, S_COL + c - 1)
End If
r = r + 1: c = c + 1
Loop Until r = RowCnt + 1 Or c = ColCnt + 1
If iCount > 6 Then
Debug.Print sCell.Address, eCell.Address
AddLine sCell, eCell
End If
End If
Next j
Next 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 Boolean
Dim i As Long, j As Long, r As Long, c As Long, sKey As String
Dim arrData, RowCnt As Long, ColCnt As Long, iCount As Long
Dim oSht1 As Worksheet, oSht2 As Worksheet
Dim sCell As Range, eCell As Range
Const S_ROW = 5
Const S_COL = 2
Set rngData = Cells(S_ROW, S_COL).CurrentRegion
arrData = rngData.Value
RowCnt = UBound(arrData)
ColCnt = UBound(arrData, 2)
For i = 1 To ColCnt
For j = 5 To RowCnt
bFlag = False
If i = 1 Or j = RowCnt Then
bFlag = True
Else
r = j + 1: c = i - 1
If r > RowCnt Then r = RowCnt
If c < 1 Then c = 1
If Not arrData(j, i) = arrData(r, c) Then bFlag = True
End If
If bFlag Then
sKey = arrData(j, i)
iCount = 0: r = j: c = i
Set sCell = Cells(S_ROW + r - 1, S_COL + c - 1)
Do
If sKey = arrData(r, c) Then
iCount = iCount + 1
Set eCell = Cells(S_ROW + r - 1, S_COL + c - 1)
Else
If iCount > 6 Then
Debug.Print sCell.Address, eCell.Address
AddLine sCell, eCell
End If
iCount = 1
sKey = arrData(r, c)
Set sCell = Cells(S_ROW + r - 1, S_COL + c - 1)
End If
r = r - 1: c = c + 1
Loop Until r = 0 Or c = ColCnt + 1
If iCount > 6 Then
Debug.Print sCell.Address, eCell.Address
AddLine sCell, eCell
End If
End If
Next j
Next i
End Sub
【代码解析】
LB2RT代码过程实现左下到右上的数据查找，其原理与LT2RB类似。
Sub Main()
ActiveSheet.DrawingObjects.Delete
LT2RB
LB2RT
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).Select
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 2
End With
End Sub
【代码解析】
第2行代码清除工作表中的全部线条。
第3~4行代码分别调用两个Sub过程查找对角线数据。
第6~14行代码用于条件线条。
第7~9行代码添加一个线条对象，并选中该对象。
第11行代码设置线条对象可见。
第11行代码设置线条粗度为2。
原文地址：https://blog.csdn.net/taller_2000/article/details/142486899
免责声明：本站文章内容转载自网络资源，如本站内容侵犯了原著者的合法权益，可联系本站删除。更多内容请关注自学内容网（zxcms.com）！