VBA编程有偿代做

1256366515 · 发表于 2022-3-22 20:51

DevilW 发表于 2022-3-22 18:53

单元格里面的字符数限定为了一个，影响实际操作

1256366515 · 发表于 2022-3-22 20:59

microyip 发表于 2022-3-22 18:05
再次附上附件以供参考

不改了，我就用单个字符单个汉字来改吧

microyip · 发表于 2022-3-22 21:04

1256366515 发表于 2022-3-22 20:59
不改了，我就用单个字符单个汉字来改吧

本来就想告诉你，唯一缺点就是单字符

microyip · 发表于 2022-3-22 23:16

这个应该能满足你的需求了

Sub CloseLink()
Dim vSplit As Variant, vSplitLink As Variant
Dim vLen As Variant, sLink As String, vLink As Variant
Dim sFirst As String, nBit As Long, sMid As String, bIsSame As Boolean, sStr As String
Dim nI As Long
With [A1].CurrentRegion
vData = .Offset(1).Resize(.Rows.Count - 1).Value
End With
Set dicData = CreateObject("Scripting.Dictionary")
For nRow = 1 To UBound(vData)
If vData(nRow, 1) <> "" And vData(nRow, 2) <> "" Then
If Not dicData.Exists(vData(nRow, 1)) Then Set dicData(vData(nRow, 1)) = CreateObject("Scripting.Dictionary")
dicData(vData(nRow, 1))(vData(nRow, 2)) = ""
End If
Next
ReDim vData(0)
nRow = 0
GetLink dicData
[D:E].ClearContents
If nRow > 0 Then
vSplit = vData
For nRow = 1 To UBound(vSplit)
vSplit(nRow) = vSplit(nRow) & "∮"
Next
[D1].Resize(UBound(vSplit)) = Application.WorksheetFunction.Transpose(vSplit)
Set dicData = CreateObject("Scripting.Dictionary")
For nRow = 1 To UBound(vData)
sLink = vData(nRow)
vSplit = Split(sLink, "→")
sFirst = vSplit(0) & "→"
vLen = UBound(vSplit) + 1
If Not dicData.Exists(vLen) Then Set dicData(vLen) = CreateObject("Scripting.Dictionary")
For Each vLink In dicData(vLen).Keys
nBit = InStr(vLink & "→", sFirst)
If nBit > 1 Then
sStr = Right(vLink & "→", Len(vLink & "→") - nBit + 1) & Left(vLink, nBit - 2)
bIsSame = sStr = sLink
If bIsSame Then Exit For
End If
Next
If Not bIsSame Then
dicData(vLen)(sLink) = 0
nI = nI + 1
If nI <> nRow Then vData(nI) = vLink
End If
bIsSame = False
Next
If nI = 1 Then
[E1] = vData(1) & "∮"
Else
For nRow = 1 To UBound(vData)
vData(nRow) = vData(nRow) & "∮"
Next
[E1].Resize(nI) = Application.WorksheetFunction.Transpose(vData)
End If
End If
End Sub
Private Function GetLink(ByVal oDic As Object, Optional ByVal sFirst As String, Optional ByVal sLink As String)
Dim vKey As Variant, vDataKey As Variant
For Each vKey In oDic.Keys
If vKey = sFirst And UBound(Split(sLink & "→" & vKey, "→")) > 1 Then
nRow = nRow + 1
ReDim Preserve vData(1 To nRow)
vData(nRow) = sLink
ElseIf Not ("→" & sLink & "→" Like "*→" & vKey & "→*") Then
If dicData.Exists(vKey) Then GetLink dicData(vKey), IIf(sFirst = "", vKey, sFirst), IIf(sLink = "", "", sLink & "→") & vKey
End If
Next
End Function

复制代码

microyip · 发表于 2022-3-22 23:16

附上附件以供参考

笨鸟飞不高 · 发表于 2022-3-23 09:00

VBA编写程序，寻找所有闭环.zip (19.24 KB, 下载次数: 2)

1256366515 · 发表于 2022-3-23 10:35

microyip 发表于 2022-3-22 23:16
附上附件以供参考

大神我用实际数据运行，结果报错。显示类型不匹配[D1].Resize(UBound(vSplit)) = Application.WorksheetFunction.Transpose(vSplit)

1256366515 · 发表于 2022-3-23 11:11

microyip 发表于 2022-3-22 23:16
附上附件以供参考

已经非常完美了，我用实际数据运行了一下，不知道为什么报错了

1256366515 · 发表于 2022-3-23 11:24

笨鸟飞不高发表于 2022-3-23 09:00

实测数据运行很久都没有结果。

microyip · 发表于 2022-3-23 11:35

1256366515 发表于 2022-3-23 11:11
已经非常完美了，我用实际数据运行了一下，不知道为什么报错了

行数太多，超出转置函数的范围，改成循环转置一次就可以了。
但这么多，惊讶中，可能要找时间研究一下效率问题了。

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

[求助] VBA编程有偿代做

评分