相同内容用线条链接起来

众望星君 · 发表于 2024-9-9 11:15

本帖最后由众望星君于 2024-9-9 15:40 编辑

连线.png

相同内容连线.7z (9.4 KB, 下载次数: 5)

taller · 发表于 2024-9-9 12:44

两个方向使用独立的Sub过程，基本查找思路是相同的，也许可以合并

Option Explicit
Sub Main()
ActiveSheet.DrawingObjects.Delete
LT2RB
LB2RT
End Sub
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
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
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

复制代码

chenjx80 · 发表于 2024-9-9 14:59

暴力出奇迹。

相同内容连线.7z (22.32 KB, 下载次数: 9)

众望星君 · 发表于 2024-9-9 14:04

taller 发表于 2024-9-9 12:44
两个方向使用独立的Sub过程，基本查找思路是相同的，也许可以合并

老大首先感谢你的支持

请问如何修改连线区域呢

众望星君 · 发表于 2024-9-9 14:49

taller 发表于 2024-9-9 12:44
两个方向使用独立的Sub过程，基本查找思路是相同的，也许可以合并

内容发生变化之后，原始连线不会清除

众望星君 · 发表于 2024-9-9 15:26

chenjx80 发表于 2024-9-9 14:59
暴力出奇迹。

非常感谢大哥支持，请问如何修改区域呢？

taller · 发表于 2024-9-9 22:13

众望星君发表于 2024-9-9 14:49
内容发生变化之后，原始连线不会清除

ActiveSheet.DrawingObjects.Delete 删除全部连线

taller · 发表于 2024-9-9 22:13

众望星君发表于 2024-9-9 14:04
老大首先感谢你的支持请问如何修改连线区域呢

Set rngData = Cells(S_ROW, S_COL).CurrentRegion - 这句代码定义数据表区域

		自动登录	找回密码
密码			免费注册

[已解决] 相同内容用线条链接起来