VBA编程有偿代做

1256366515

笨鸟飞不高 发表于 2022-3-22 16:41

大神这个方案，唯一的问题是没有解决，重复闭环的问题
重复闭环比如A,B,C,A和B,C,A,B是同一个闭环，方向相同只是起点不一样；ACBA却不是一样的环

1256366515

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

大神这个方案，唯一的问题也是没有解决，重复闭环的问题
重复闭环比如A,B,C,A和B,C,A,B是同一个闭环，方向相同只是起点不一样；ACBA却不是一样的环

1256366515

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

您的这个方法，唯一的问题是没有解决，重复闭环的问题
重复闭环比如A,B,C,A和B,C,A,B是同一个闭环，方向相同只是起点不一样；ACBA却不是一样的环

DevilW

还缺少个重复处理机制

DevilW

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary") '人数及流向
   
4.     Set reg = CreateObject("vbScript.Regexp")
   
5.     reg.Global = True
   
6.     reg.Pattern = "(\S)\S*\1" '重复字符关键字
   
7.     ar = [a1:b8]
   
8.     For i = 1 To UBound(ar)
   
9.         s = ar(i, 1)
   
10.         d1(s) = d1(s) & ar(i, 2) 'key 流向 item
    
11.     Next
    
12.     For i = 1 To d1.Count
    
13.         If i = 1 Then '处理第1层流向
    
14.         sk = d1.keys
    
15.             For Each k In sk
    
16.                 s = d1(k)
    
17.                 For j = 1 To Len(s)
    
18.                     t = Mid(s, j, 1)
    
19.                     d(k & t) = ""
    
20.                 Next
    
21.             Next
    
22.         Else '处理第2层以上流向
    
23.             sk = d.keys
    
24.             d.RemoveAll
    
25.             For Each k In sk
    
26.                 s = d1(Right(k, 1))
    
27.                 For j = 1 To Len(s)
    
28.                     t = Mid(s, j, 1)
    
29.                     sn = k & t
    
30.                     If reg.test(sn) Then '有重复
    
31.                         If Mid(sn, 1, 1) = Right(sn, 1) And Len(sn) > 3 Then
    
32.                             n = n & " " & sn '首尾相同且至少3人则记录
    
33.                         End If
    
34.                     Else
    
35.                         d(sn) = "" '字典继续记录未闭环流向
    
36.                     End If
    
37.                 Next
    
38.             Next
    
39.         End If
    
40.     Next
    
41.     n = Split(Trim(n)) '去首尾空格然后拆分
    
42.     Debug.Print Join(n, Chr(10))
    
43. End Sub

复制代码

microyip

1. Sub CloseLink()
   
2.     Dim vLen As Variant, sLink As String, vLink As Variant
   
3.     Dim sFirst As String, nBit As Long, sMid As String, bIsSame As Boolean, sStr As String
   
4.     Dim nI As Long
   
5.    
   
6.     With [A1].CurrentRegion
   
7.         vData = .Offset(1).Resize(.Rows.Count - 1).Value
   
8.     End With
   
9.     Set dicData = CreateObject("Scripting.Dictionary")
   
10.     For nRow = 1 To UBound(vData)
    
11.         If vData(nRow, 1) <> "" And vData(nRow, 2) <> "" Then
    
12.             If Not dicData.Exists(vData(nRow, 1)) Then Set dicData(vData(nRow, 1)) = CreateObject("Scripting.Dictionary")
    
13.             dicData(vData(nRow, 1))(vData(nRow, 2)) = ""
    
14.         End If
    
15.     Next
    
16.     ReDim vData(0)
    
17.     nRow = 0
    
18.    
    
19.     GetLink dicData
    
20.     [D:E].ClearContents
    
21.     If nRow > 0 Then
    
22.         [D1].Resize(nRow) = Application.WorksheetFunction.Transpose(vData)
    
23.         Set dicData = CreateObject("Scripting.Dictionary")
    
24.         For nRow = 1 To UBound(vData)
    
25.             sLink = vData(nRow)
    
26.             sFirst = Left(sLink, 1)
    
27.             vLen = Len(sLink)
    
28.             If Not dicData.Exists(vLen) Then Set dicData(vLen) = CreateObject("Scripting.Dictionary")
    
29.             For Each vLink In dicData(vLen).Keys
    
30.                 If Left(vLink, 1) <> sFirst Then
    
31.                     sMid = Mid(vLink, 2, Len(vLink) - 2)
    
32.                     nBit = InStr(sMid, sFirst)
    
33.                     If nBit > 0 Then
    
34.                         sStr = Right(vLink, Len(vLink) - nBit) & IIf(nBit > 2, Mid(vLink, 2, nBit), "") & sFirst
    
35.                         bIsSame = sStr = sLink
    
36.                     End If
    
37.                     If bIsSame Then Exit For
    
38.                 End If
    
39.             Next
    
40.             If Not bIsSame Then
    
41.                 dicData(vLen)(sLink) = 0
    
42.                 nI = nI + 1
    
43.                 If nI <> nRow Then vData(nI) = vLink
    
44.             End If
    
45.             bIsSame = False
    
46.         Next
    
47.         If nI = 1 Then
    
48.             [E1] = vData(1)
    
49.         Else
    
50.             [E1].Resize(nI) = Application.WorksheetFunction.Transpose(vData)
    
51.         End If
    
52.     End If
    
53. End Sub
    
54. 
    
55. Private Function GetLink(ByVal oDic As Object, Optional ByVal sFirst As String, Optional ByVal sLink As String)
    
56.     Dim vKey As Variant, vDataKey As Variant
    
57.    
    
58.     For Each vKey In oDic.Keys
    
59.         If vKey = sFirst And Len(sLink & vKey) > 2 Then
    
60.             nRow = nRow + 1
    
61.             ReDim Preserve vData(1 To nRow)
    
62.             vData(nRow) = sLink & vKey
    
63.         ElseIf Not (sLink Like "*" & vKey & "*") Then
    
64.             If dicData.Exists(vKey) Then GetLink dicData(vKey), IIf(sFirst = "", vKey, sFirst), sLink & vKey
    
65.         End If
    
66.     Next
    
67. End Function

复制代码

microyip

再次附上附件以供参考

DevilW

DevilW

1. Sub test()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set d1 = CreateObject("scripting.dictionary") '人数及流向
   
4.     Set reg = CreateObject("vbScript.Regexp")
   
5.     reg.Global = True
   
6.     reg.Pattern = "(\S)\S*\1" '重复字符关键字
   
7.     ar = [a1:b8]
   
8.     For i = 1 To UBound(ar)
   
9.         s = ar(i, 1)
   
10.         d1(s) = d1(s) & ar(i, 2) 'key 流向 item
    
11.     Next
    
12.     For i = 1 To d1.Count
    
13.         If i = 1 Then '处理第1层流向
    
14.         sk = d1.keys
    
15.             For Each k In sk
    
16.                 s = d1(k)
    
17.                 For j = 1 To Len(s)
    
18.                     t = Mid(s, j, 1)
    
19.                     d(k & t) = ""
    
20.                 Next
    
21.             Next
    
22.         Else '处理第2层以上流向
    
23.             sk = d.keys
    
24.             d.RemoveAll
    
25.             For Each k In sk
    
26.                 s = d1(Right(k, 1))
    
27.                 For j = 1 To Len(s)
    
28.                     t = Mid(s, j, 1)
    
29.                     sn = k & t
    
30.                     If reg.test(sn) Then '有重复
    
31.                         If Mid(sn, 1, 1) = Right(sn, 1) And Len(sn) > 3 Then
    
32.                             n = n & " " & Mid(sn, 2) '首尾相同且至少3人则记录
    
33.                         End If
    
34.                     Else
    
35.                         d(sn) = "" '字典继续记录未闭环流向
    
36.                     End If
    
37.                 Next
    
38.             Next
    
39.         End If
    
40.     Next
    
41.     n = Split(Trim(n)) '去首尾空格然后拆分
    
42.     d.RemoveAll
    
43.     For Each sn In n '处理重复流向机制
    
44.         m = 0
    
45.         For i = 1 To Len(sn)
    
46.             t = Mid(sn, i) & Mid(sn, 1, i - 1)
    
47.             If d.exists(t) Then m = 1
    
48.         Next
    
49.         If m = 0 Then d(sn) = "": Debug.Print sn
    
50.     Next
    
51. End Sub

复制代码

1256366515

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

去重部分经过检测，比如将字母B 替换成“中国”，程序无法去重