问题有点难~！期盼大神解决，也欢迎来学习探讨~！先谢为敬

问题文件：
https://wwst.lanzout.com/ixTgW199ulsj

手动解决的视频：
https://wwst.lanzout.com/iFMrK199ulxe

虽然感觉有点像文本处理，但是感觉离开excel办不了事情。
我说的话有点哆嗦，可能表达的不清，请大家谅解。

太麻烦了 ,要VBA了

不怎么难，公式就可以的。

这种需求放在这里基本上不会有人给弄，vba找专人做吧。

这个问题就是麻烦，他不难，我这里少做了3个部分，一部分是把结果输出在c列没有加进数组，第二部分是默认A列单元格里面字符串按照”--“的数值自动升序，但是要加也可以，只是个示例；第三部分是目前没有加A列循环，但是整体已经没问题了，如果有贴吧老哥想继续做可以添加进去。但是整体已经可以直接输出结果了。

Sub 问题一二三()
Dim reg, reg2, dic, dic2, sols, sols2, arr, brr, crr, drr, err, frr
Dim str As String, str2 As String
Dim a, b, c, d, e, f, g, h, m, s
Columns("c").Clear
Set reg = CreateObject("vbscript.regexp")
Set reg2 = CreateObject("vbscript.regexp")
Set dic = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
reg.Global = True
reg.Pattern = "\d+([\u4e00-\u9fa5]+)"
reg2.Global = True
reg2.Pattern = "(\d+\+\d+)--(\d+\+\d+)"
arr = Split(Cells(1, 1).Value, Chr(10))
For a = 0 To UBound(arr, 1)
Set sols = reg.Execute(arr(a))
str = sols(0).submatches(0)
dic(str) = ""
Next
brr = dic.keys
dic.RemoveAll
For b = 0 To UBound(brr, 1)
str = ""
For a = UBound(arr, 1) To 0 Step -1
If arr(a) Like "*" & brr(b) & "*" Then
str = arr(a) & "," & str
s = s + 1
End If
Next
crr = Split(str, ",")
ReDim err(1 To s, 1 To 2)
For c = 0 To UBound(crr, 1) - 1
drr = Split(crr(c), "、")
d = d + 1
err(d, 1) = drr(UBound(drr, 1))
Next
For e = 1 To s
m = Cells(Rows.Count, 3).End(xlUp).Row + 1
If dic.exists(err(e, 1)) And Cells(m - 1, 3).Value <> err(e, 1) Then
f = f + 1
Cells(m, 3) = err(e, 1)
End If
dic(err(e, 1)) = ""
Next
crr = dic.keys
h = 0
ReDim frr(1 To dic.Count - f, 1 To 2)
For e = 1 To dic.Count - f
For c = h To UBound(crr, 1)
For g = 2 To Cells(Rows.Count, 3).End(xlUp).Row
If crr(c) = Cells(g, 3).Value Then
Exit For
End If
Next
If g > Cells(Rows.Count, 3).End(xlUp).Row Then
frr(e, 1) = crr(c)
Exit For
Else
h = h + 1
End If
Next
h = h + 1
Next
dic.RemoveAll
err = []
crr = []
drr = []
str2 = frr(1, 1)
For g = 1 To UBound(frr, 1) - 1
Set sols2 = reg2.Execute(frr(g, 1))
name1 = sols2(0).submatches(1)
Set sols2 = reg2.Execute(frr(g + 1, 1))
name2 = sols2(0).submatches(0)
name3 = sols2(0).submatches(1)
If name1 = name2 Then
str2 = Replace(str2, name1, name3)
Else
m = Cells(Rows.Count, 3).End(xlUp).Row + 1
Cells(m, 3) = str2
str2 = frr(g + 1, 1)
End If
Next
m = Cells(Rows.Count, 3).End(xlUp).Row + 1
Cells(m, 3) = str2
f = 0
s = 0
d = 0
Next
crr = []
str = ""
m = Cells(Rows.Count, 3).End(xlUp).Row
crr = Range("c2: c" & m)
d = m - 1
For c = UBound(crr, 1) To 1 Step -1
str = d & "、" & crr(c, 1) & Chr(10) & str
d = d - 1
Next
Cells(1, 2) = str
End Sub

真*屎山代码

Sub 问题一二三()
Dim reg, reg2, dic, sols, sols2, arr, brr, crr, drr, err, frr, grr, hrr, irr
Dim str As String, str2 As String
Dim va As Long
Dim a, b, c, d, e, f, g, h, m, s, str3, str4, row, row2, ccount, i, str5
Columns("c").Clear
Set reg = CreateObject("vbscript.regexp")
Set reg2 = CreateObject("vbscript.regexp")
Set dic = CreateObject("scripting.dictionary")
reg.Global = True
reg.Pattern = "\d+([\u4e00-\u9fa5]+)"
reg2.Global = True
reg2.Pattern = "(\d+\+\d+)--(\d+\+\d+)"
For ccount = 1 To Cells(Rows.Count, 1).End(xlUp).row
arr = Split(Cells(ccount, 1), Chr(10))
For a = 0 To UBound(arr, 1)
If arr(a) <> "" Then
Set sols = reg.Execute(arr(a))
str = sols(0).submatches(0)
dic(str) = ""
End If
Next
brr = dic.keys
grr = dic.keys
dic.RemoveAll
For b = 0 To UBound(brr, 1)
str = ""
For a = UBound(arr, 1) To 0 Step -1
If arr(a) Like "*" & brr(b) & "*" Then
str = arr(a) & "," & str
s = s + 1
End If
Next
crr = Split(str, ",")
ReDim err(1 To s, 1 To 2)
For c = 0 To UBound(crr, 1) - 1
drr = Split(crr(c), "、")
d = d + 1
err(d, 1) = drr(UBound(drr, 1))
Next
For e = 1 To s
m = Cells(Rows.Count, 3).End(xlUp).row + 1
If dic.exists(err(e, 1)) And Cells(m - 1, 3).Value <> err(e, 1) Then
f = f + 1
Cells(m, 3) = err(e, 1)
End If
dic(err(e, 1)) = ""
Next
crr = dic.keys
h = 0
ReDim frr(1 To dic.Count - f, 1 To 2)
For e = 1 To dic.Count - f
For c = h To UBound(crr, 1)
For g = 2 To Cells(Rows.Count, 3).End(xlUp).row
If crr(c) = Cells(g, 3).Value Then
Exit For
End If
Next
If g > Cells(Rows.Count, 3).End(xlUp).row Then
frr(e, 1) = crr(c)
Exit For
Else
h = h + 1
End If
Next
h = h + 1
Next
dic.RemoveAll
crr = []
drr = []
str2 = frr(1, 1)
For g = 1 To UBound(frr, 1) - 1
Set sols2 = reg2.Execute(frr(g, 1))
name1 = sols2(0).submatches(1)
Set sols2 = reg2.Execute(frr(g + 1, 1))
name2 = sols2(0).submatches(0)
name3 = sols2(0).submatches(1)
If name1 = name2 Then
str2 = Replace(str2, name1, name3)
Else
m = Cells(Rows.Count, 3).End(xlUp).row + 1
Cells(m, 3) = str2
str2 = frr(g + 1, 1)
End If
Next
m = Cells(Rows.Count, 3).End(xlUp).row + 1
Cells(m, 3) = str2
f = 0
s = 0
d = 0
Next
crr = []
str = ""
m = Cells(Rows.Count, 3).End(xlUp).row
crr = Range("c2: c" & m)
For row = 1 To UBound(crr, 1)
num = InStr(crr(row, 1), "-")
str3 = Mid(crr(row, 1), 1, num - 1)
Set sols3 = reg.Execute(crr(row, 1))
str5 = sols3(0).submatches(0)
For row2 = 0 To UBound(arr, 1)
If arr(row2) Like "*" & str3 & "*" And arr(row2) Like "*" & str5 & "*" Then
num2 = InStr(arr(row2), "-")
str4 = Mid(arr(row2), 1, num2 - 1)
Exit For
End If
Next
crr(row, 1) = Replace(crr(row, 1), str3, str4)
Next
ReDim hrr(1 To UBound(crr, 1), 1 To 2)
ReDim irr(1 To UBound(crr, 1), 1 To 2)
For i = 1 To UBound(crr, 1)
count1 = Split(crr(i, 1), "、")
va = count1(LBound(count1, 1))
hrr(i, 1) = va
hrr(i, 2) = count1(UBound(count1, 1))
Next
minval = 1
For i = 1 To UBound(crr, 1)
Min = hrr(i, 1)
min2 = hrr(i, 1)
min3 = hrr(i, 2)
For j = minval + 1 To UBound(crr, 1)
If Min < hrr(j, 1) Then
Else
Min = hrr(j, 1)
minval = j
End If
Next
If Min < hrr(i, 1) Then
hrr(i, 1) = Min
hrr(minval, 1) = min2
hrr(i, 2) = hrr(minval, 2)
hrr(minval, 2) = min3
irr(i, 1) = hrr(i, 1) & "、" & hrr(i, 2)
Else
irr(i, 1) = hrr(i, 1) & "、" & hrr(i, 2)
End If
minval = i + 1
Next
For c = UBound(irr, 1) To 1 Step -1
str = irr(c, 1) & Chr(10) & str
Next
Cells(ccount, 2) = str
d = 0
Columns("c").Clear
Next
End Sub