VBA代码求助，遍历相同的字母组合？

Posted 2023-04-12

高手你好，单词表中有1830个单词，如何遍历至少三个字母相同的字母组合，如glove,dove都有相同的字母组合ove，又如corner,popcorn中都有相同的字母组合corn，而corn本身就是一个单词。希望列举相同的字母组合又附上代码。就是把1830个单词中任意两个单词可能相同的部分找出来，任意两个单词，可能有相同的部分，可能没有。相同的部分至少有三个字母。

以下是修改后的VBA代码，用于遍历1830个单词表中至少三个字母相同的字母组合，并输出相同的部分：
Sub FindCommonLetterCombinations()
'定义变量
Dim words() As String
Dim i, j, k, l, m As Integer
Dim commonLetters As String

'读取单词表
words = Split("apple,banana,pear,orange,grape,pineapple,kiwi,strawberry,melon,papaya,durian,peach,lemon,lime,cherry,blueberry,raspberry,mango,watermelon,avocado,apricot,fig,guava", ",")

'遍历单词表
For i = 0 To UBound(words)
For j = i + 1 To UBound(words)
'查找相同的字母组合
For k = 1 To Len(words(i))
For l = 1 To Len(words(j))
If Mid(words(i), k, 3) = Mid(words(j), l, 3) And Len(words(i)) >= k + 2 And Len(words(j)) >= l + 2 Then
For m = 4 To Len(words(i)) - (k - 1)
If Mid(words(i), k + m - 1, 1) <> Mid(words(j), l + m - 1, 1) Then
Exit For
Else
If m >= 3 Then
commonLetters = Mid(words(i), k, m)
Debug.Print "单词 " & words(i) & " 和 " & words(j) & " 共享字母组合: " & commonLetters
End If
End If
Next m
End If
Next l
Next k
Next j
Next i
End Sub
这段代码会输出所有至少有三个字母相同的字母组合，并附上它们所属的两个单词。为了避免重复输出相同的字母组合，代码只会在第一次找到时输出，并忽略后续重复出现的情况。
需要注意的是，由于要考虑多种可能的组合，代码执行时间可能较长，特别是在单词列表较大时。如果您需要处理更大的数据集或提高代码效率，可以考虑使用其他算法或工具进行优化。追问

你好，输出到另一张表怎么弄？

追答

可以使用Python编写一个程序来实现这个功能。
from collections import defaultdict
# 读取单词列表
with open('wordlist.txt') as f:
words = [line.strip() for line in f]
# 创建一个字典，用于存储每个字母组合出现的单词列表
combinations = defaultdict(list)
# 遍历每个单词，找到所有可能的字母组合
for word in words:
for i in range(len(word) - 2):
combination = word[i:i+3]
combinations[combination].append(word)
# 创建一个新表单，列举相同的字母组合及其对应的单词列表
with open('combinations.txt', 'w') as f:
for combination, word_list in combinations.items():
if len(word_list) > 1: # 只记录有多个单词的组合
f.write(combination + ': ' + ', '.join(word_list) + '\n')
这个程序首先读取一个单词列表（假设其保存在名为 wordlist.txt 的文件中），然后遍历每个单词并找到所有可能的三个字母组合。通过将每个组合与其对应的单词列表存储在一个 defaultdict 中，我们可以很容易地找到具有相同组合的单词。
最后，该程序创建一个新的表单，将所有具有多个单词的组合及其对应的单词列表写入其中（假设该表单保存在名为 combinations.txt 的文件中）。
希望能解决你的问题 或者有相对更好的解决方案

追问

我怎么做能给你发原文件？

追答

可以使用VBA代码在Excel中创建一个新的工作表，并将需要输出的数据写入该工作表
你试一下
Sub CreateNewSheet()
' 创建新工作表并指定名称
Dim newSheet As Worksheet
Set newSheet = ThisWorkbook.Sheets.Add
newSheet.Name = "NewSheet"

' 将数据写入新工作表
newSheet.Cells(1, 1).Value = "Hello World!"
End Sub
代码将创建一个名为“NewSheet”的新工作表，并在其A1单元格中输入“Hello World!”文本。根据需要，您可以使用更复杂的VBA代码来从其他工作表或数据源中提取数据并将其写入新工作表中

参考技术A 以下是VBA代码，用于查找1830个单词中至少三个字母相同的字母组合并输出相同的部分。
Sub FindCommonLetterCombinations()
'定义变量
Dim words() As String
Dim i, j, k, l, m As Integer
Dim commonLetters As String

'读取单词表 words=Split("apple,banana,pear,orange,grape,pineapple,kiwi,strawberry,melon,papaya,durian,peach,lemon,lime,cherry,blueberry,raspberry,mango,watermelon,avocado,apricot,fig,guava", ",")

'遍历单词表
For i = 0 To UBound(words)
For j = i + 1 To UBound(words)
'查找相同的字母组合
For k = 1 To Len(words(i))
For l = 1 To Len(words(j)) - (k - 1)
If Mid(words(i), k, 1) = Mid(words(j), l, 1) Then
For m = 2 To Len(words(i)) - (k - 1)
If Mid(words(i), k + m - 1, 1) <> Mid(words(j), l + m - 1, 1)
Then
Exit For
Else
If m >= 3 Then
commonLetters = Mid(words(i), k, m)
Debug.Print "单词 " & words(i) & " 和 " & words(j) & " 共享字母组 合: " & commonLetters
End If
End If
Next m
End If
Next l
Next k
Next j
Next i
End Sub

该代码首先读取了一个包含1830个单词的数组，然后通过嵌套循环遍历数组中每个单词的每个字符，并查找与其他单词中相同的字符。如果找到相同的字符，则继续比较后续字符是否相同，直到不相同为止。如果相同的字符数量大于等于3，则将它们输出到控制台窗口。
请注意，由于代码使用了嵌套循环，因此当单词表非常大时，可能需要一些时间才能执行完毕。

[求助] excel VBA多条件求和代码优化

Sub 佳兴汇总()
Range("B5") = Application.WorksheetFunction.SumIfs(Sheet2.Range("C:C"), Sheet2.Range("A:A"), Range("A5"), Sheet2.Range("B:B"), Range("B3"))Range("C5") = Application.WorksheetFunction.SumIfs(Sheet2.Range("D:D"), Sheet2.Range("A:A"), Range("A5"), Sheet2.Range("B:B"), Range("B3"))Range("E5") = Application.WorksheetFunction.SumIfs(Sheet2.Range("E:E"), Sheet2.Range("A:A"), Range("A5"), Sheet2.Range("B:B"), Range("B3"))
End Sub

因为物料编码很多，一个编码一条代码，会很长，请问一下，要如何解决这个问题

这种情况用字典法最合适

Sub test()
arr = Sheet2.Range("A1:E" & Sheet2.[a65536].End(xlUp).Row) 'Sheet2数据存入数组
Set d1 = CreateObject("Scripting.Dictionary") '外发字典
Set d2 = CreateObject("Scripting.Dictionary") '返回字典
Set d3 = CreateObject("Scripting.Dictionary") '生产字典
For i = 1 To UBound(arr)
d1(arr(i, 1) & arr(i, 2)) = d1(arr(i, 1) & arr(i, 2)) + arr(i, 3)
d2(arr(i, 1) & arr(i, 2)) = d1(arr(i, 1) & arr(i, 2)) + arr(i, 4)
d3(arr(i, 1) & arr(i, 2)) = d1(arr(i, 1) & arr(i, 2)) + arr(i, 5)
Next
For i = 2 To [iv3].End(xlToLeft) Step 4
For j = 5 To [a65536].End(xlUp).Row
Cells(j, i) = d1(Cells(j, 1).Value & Cells(3, i).Value)
Cells(j, i + 1) = d2(Cells(j, 1).Value & Cells(3, i).Value)
Cells(j, i + 3) = d3(Cells(j, 1).Value & Cells(3, i).Value)
Next
Next
End Sub

参考技术A

要使用变量，用with，就可以化简很多。而且速度快的多，因为不需要每次都去找对象。 

Sub 佳兴汇总()
Dim MyRng(1 To 5) As Range, B3 As String, i As Long
B3 = Range("B3").Value
With Sheet2
    For i = 1 To 5
        Set MyRng(i) = .Columns(i)
    Next i
End With
With Application.WorksheetFunction
For i = 5 To 12 '5到12行
Range("B" & i) = .SumIfs(MyRng(3), MyRng(1), Range("A" & i), MyRng(2), B3)
Range("C" & i) = .SumIfs(MyRng(4), MyRng(1), Range("A" & i), MyRng(2), B3)
Range("E" & i) = .SumIfs(MyRng(5), MyRng(1), Range("A" & i), MyRng(2), B3)
Next i
End With
Erase MyRng
End Sub

追问

这个看不明白,不过还是谢谢你.

追答

这是基础。

参考技术B 没有代码，是没有办法“优化”代码的。追问

刚刚加上去了，之前添加不了，说内容太长了。

追答

试试下面的代码行不？
Sub 佳兴汇总()
Dim i%
For i = 5 To 12
Range("B" & i) = Application.WorksheetFunction.SumIfs(Sheet2.Range("C:C"), Sheet2.Range("A:A"), Range("A" & i), Sheet2.Range("B:B"), Range("B3"))
Range("C" & i) = Application.WorksheetFunction.SumIfs(Sheet2.Range("D:D"), Sheet2.Range("A:A"), Range("A" & i), Sheet2.Range("B:B"), Range("B3"))
Range("E" & i) = Application.WorksheetFunction.SumIfs(Sheet2.Range("E:E"), Sheet2.Range("A:A"), Range("A" & i), Sheet2.Range("B:B"), Range("B3"))
Next i
End Sub

追问

谢谢，这样可以的。非常感谢。再请教一个问题，D5＝B5－C5，D6＝B6－C6……一直递加下去。VBA怎么写，写成上面的那个样子

追答

以上代码还可简写为：
Sub 佳兴汇总()Dim i%
With Application.WorksheetFunction
For i = 5 To 12 Range("B" & i) = .SumIfs(Sheet2.Range("C:C"), Sheet2.Range("A:A"), Range("A" & i), Sheet2.Range("B:B"), Range("B3")) Range("C" & i) = .SumIfs(Sheet2.Range("D:D"), Sheet2.Range("A:A"), Range("A" & i), Sheet2.Range("B:B"), Range("B3")) Range("E" & i) = .SumIfs(Sheet2.Range("E:E"), Sheet2.Range("A:A"), Range("A" & i), Sheet2.Range("B:B"), Range("B3")) Next i
End WithEnd Sub

D5＝B5－C5，D6＝B6－C6……一直递加下去：
Sub 对应相减()
Dim i%
For i = 5 to [B65536].End(3).Row
Cells(i , 4) = Cells(i , 2) - Cells(i , 3)
Next i
End Sub

本回答被提问者采纳 参考技术C 求助高手：怎样用VBA实现多条件计数：比如使工作表2中某一单元格等于工作表1中某几列中的某些条件个数，如中学、男、大于26小于30岁等