VBA编程有偿代做

笨鸟飞不高 · 发表于 2022-3-23 13:22

本帖最后由笨鸟飞不高于 2022-3-23 16:06 编辑

1256366515 发表于 2022-3-23 11:24
实测数据运行很久都没有结果。

..............................

1256366515 · 发表于 2022-3-23 14:39

笨鸟飞不高发表于 2022-3-23 13:22
未验证正确性！！

结果如图，本该终止了，又形成了一个环状

DevilW · 发表于 2022-3-23 15:17

1256366515 发表于 2022-3-22 20:51
单元格里面的字符数限定为了一个，影响实际操作

可以用字典做个映射，单字符做 KEY，全称放到 ITEM 里去

笨鸟飞不高 · 发表于 2022-3-23 15:36

1256366515 发表于 2022-3-23 14:39
结果如图，本该终止了，又形成了一个环状

是的，递归还没入门，凭感觉写的

1256366515 · 发表于 2022-3-23 17:22

笨鸟飞不高发表于 2022-3-23 15:36
是的，递归还没入门，凭感觉写的

这样的话就会造成本来很多是重复的，你再加一个环，编程不重复的，结果这么多行，没有办法使用的

笨鸟飞不高 · 发表于 2022-3-23 19:01

1256366515 发表于 2022-3-23 17:22
这样的话就会造成本来很多是重复的，你再加一个环，编程不重复的，结果这么多行，没有办法使用的

你参照其他大神的吧，我的可以忽略

1256366515 · 发表于 2022-3-23 19:32

笨鸟飞不高发表于 2022-3-23 19:01
你参照其他大神的吧，我的可以忽略

已经非常感谢了

microyip · 发表于 2022-3-23 20:49

将系统转置数组修改为循环转置数组，解决出错问题。
但因为数据太多，运行时间太长，几个小时，47812个闭环，太恐怖了

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
ReDim vSplit(1 To UBound(vData), 1 To 1)
For nRow = 1 To UBound(vSplit)
If Trim(vData(nRow)) <> "" Then vSplit(nRow, 1) = vData(nRow) & "∮"
Next
[D1].Resize(UBound(vSplit)) = 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
ReDim vSplit(1 To nI, 1 To 1)
For nRow = 1 To UBound(vSplit)
If Trim(vData(nRow)) <> "" Then vSplit(nRow, 1) = vData(nRow) & "∮"
Next
[E1].Resize(nI) = vSplit
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-23 20:51

只能把已经运行的结果附上，至于优化问题，有空再研究

microyip · 发表于 2022-3-24 11:02

调整算法，从6小时缩减到3小时了

Private vData As Variant, nRow As Long, dicData As Object, dicCloseLink As Object, dicMinFirst As Object
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
[G1] = Now()
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 Trim(vData(nRow, 1)) <> "" And Trim(vData(nRow, 2)) <> "" Then
If Not dicData.Exists(Trim(vData(nRow, 1))) Then Set dicData(Trim(vData(nRow, 1))) = CreateObject("Scripting.Dictionary")
dicData(Trim(vData(nRow, 1)))(Trim(vData(nRow, 2))) = ""
End If
Next
ReDim vData(0)
nRow = 0
Set dicCloseLink = CreateObject("Scripting.Dictionary")
Set dicMinFirst = CreateObject("Scripting.Dictionary")
GetLink dicData
[D:E].ClearContents
If nRow > 0 Then
ReDim vSplit(1 To UBound(vData), 1 To 1)
For nRow = 1 To UBound(vSplit)
If Trim(vData(nRow)) <> "" Then vSplit(nRow, 1) = vData(nRow) & "∮"
Next
[D1].Resize(UBound(vSplit)) = vSplit
End If
[H1] = Now()
End Sub
Private Function GetLink(ByVal oDic As Object, Optional ByVal dicLink As Object)
Dim vKey As Variant, dicTmp As Object, vTmp As Variant, sMin As String, sMinFirst As String, nI As Long
If dicLink Is Nothing Then Set dicLink = CreateObject("Scripting.Dictionary")
For Each vKey In oDic.Keys
If Not dicLink.Exists(vKey) Then
If dicData.Exists(vKey) Then
Set dicTmp = CreateObject("Scripting.Dictionary")
For Each vTmp In dicLink.Keys
dicTmp(vTmp) = dicTmp.Count
Next
dicTmp(vKey) = dicTmp.Count
GetLink dicData(vKey), dicTmp
End If
ElseIf dicLink.Count > 2 Then
If vKey = dicLink.Keys()(0) Then
sMinFirst = FindMin(dicLink.Keys())
If dicLink.Keys()(0) = sMinFirst Then
sMin = Join(dicLink.Keys(), "→")
Else
Set dicTmp = CreateObject("Scripting.Dictionary")
For nI = dicLink(sMinFirst) To dicLink.Count - 1
dicTmp(dicLink.Keys()(nI)) = dicTmp.Count
Next
For Each vTmp In dicLink.Keys
If vTmp = sMinFirst Then Exit For
dicTmp(vTmp) = dicTmp.Count
Next
sMin = Join(dicTmp.Keys(), "→")
End If
If Not dicMinFirst.Exists(sMin) Then
dicMinFirst(sMin) = 0
nRow = nRow + 1
ReDim Preserve vData(1 To nRow)
vData(nRow) = Join(dicLink.Keys(), "→")
End If
End If
End If
Next
End Function
Private Function FindMin(ByVal vMin As Variant) As String
Dim nI As Double, nJ As Double, vTmp As Variant
nJ = LBound(vMin)
For nI = LBound(vMin) To UBound(vMin) - 1
If vMin(nI) <= vMin(nI + 1) Then
If nI > nJ Then
nJ = nI
Else
nI = nJ
End If
Else
vTmp = vMin(nI)
vMin(nI) = vMin(nI + 1)
vMin(nI + 1) = vTmp
If nI <> LBound(vMin) Then nI = nI - 2
End If
Next nI
FindMin = vMin(LBound(vMin))
End Function

复制代码

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

[求助] VBA编程有偿代做

评分