这个是可以完美运行的程序
Sub CountKeywords()
Dim ws As Worksheet
Dim lastRow As Long
Dim cell As Range
Dim countDict1 As Object
Dim countDict2 As Object
Dim countDict3 As Object
Dim countDict4 As Object
Dim countDict5 As Object
Dim countDict6 As Object
Dim countDict7 As Object
Dim countDict8 As Object
Dim countDict9 As Object
Dim countDict10 As Object
Dim countDict11 As Object
Dim countDict12 As Object
Dim countDict13 As Object
Dim countDict14 As Object
Dim keyword As Variant
Dim result1 As String
Dim result2 As String
Dim result3 As String
Dim result4 As String
Dim result5 As String
Dim result6 As String
Dim result7 As String
Dim result8 As String
Dim result9 As String
Dim result10 As String
Dim result11 As String
Dim result12 As String
Dim result13 As String
Dim result14 As String
Set ws = ThisWorkbook.Worksheets("Sheet1") ' 替换为您的工作表名称
lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row
Set countDict1 = CreateObject("Scripting.Dictionary")
Set countDict2 = CreateObject("Scripting.Dictionary")
Set countDict3 = CreateObject("Scripting.Dictionary")
Set countDict4 = CreateObject("Scripting.Dictionary")
Set countDict5 = CreateObject("Scripting.Dictionary")
Set countDict6 = CreateObject("Scripting.Dictionary")
Set countDict7 = CreateObject("Scripting.Dictionary")
Set countDict8 = CreateObject("Scripting.Dictionary")
Set countDict9 = CreateObject("Scripting.Dictionary")
Set countDict10 = CreateObject("Scripting.Dictionary")
Set countDict11 = CreateObject("Scripting.Dictionary")
Set countDict12 = CreateObject("Scripting.Dictionary")
Set countDict13 = CreateObject("Scripting.Dictionary")
Set countDict14 = CreateObject("Scripting.Dictionary")
' 遍历A列单元格
For Each cell In ws.Range("A1:A" & lastRow)
If cell.value <> "" Then
' 检查单元格内容是否匹配关键词
For Each keyword In Array("中府", "云门", "天府", "侠白", "尺泽", "孔最", "列缺", "经渠", "太渊", "鱼际", "少商")
If InStr(1, cell.value, keyword) > 0 Then
' 更新关键词频次计数
If countDict1.Exists(keyword) Then
countDict1(keyword) = countDict1(keyword) + 1
Else
countDict1(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("商阳", "二间", "三间", "合谷", "阳溪", "偏历", "温溜", "下廉", "上廉", "手三里", "曲池", "肘髎", "手五里", "臂臑", "肩髃", "巨骨", "天鼎", "扶突", "口禾髎", "迎香")
If InStr(1, cell.value, keyword) > 0 Then
If countDict2.Exists(keyword) Then
countDict2(keyword) = countDict2(keyword) + 1
Else
countDict2(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("承泣", "四白", "巨髎", "地仓", "大迎", "颊车", "下关", "头维", "人迎", "水突", "气舍", "缺盆", "气户", "库房", "屋翳", "膺窗", "乳中", "乳根", "不容", "承满", "梁门", "关门", "太乙", "滑肉门", "天枢", "外陵", "大巨", "水道", "归来", "气冲", "髀关", "伏兔", "阴市", "梁丘", "犊鼻", "足三里", "上巨虚", "条口", "下巨虚", "丰隆", "解溪", "冲阳", "陷谷", "内庭", "厉兑")
If InStr(1, cell.value, keyword) > 0 Then
If countDict3.Exists(keyword) Then
countDict3(keyword) = countDict3(keyword) + 1
Else
countDict3(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("隐白", "大都", "太白", "公孙", "商丘", "三阴交", "漏谷", "地机", "阴陵泉", "血海", "箕门", "冲门", "府舍", "腹结", "大横", "腹哀", "食窦", "天溪", "胸乡", "周荣", "大包")
If InStr(1, cell.value, keyword) > 0 Then
If countDict4.Exists(keyword) Then
countDict4(keyword) = countDict4(keyword) + 1
Else
countDict4(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("极泉", "青灵", "少海", "灵道", "通里", "阴郄", "神门", "少府", "少冲")
If InStr(1, cell.value, keyword) > 0 Then
If countDict5.Exists(keyword) Then
countDict5(keyword) = countDict5(keyword) + 1
Else
countDict5(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("少泽", "前谷", "后溪", "腕骨", "阳谷", "养老", "支正", "小海", "肩贞", "臑俞", "天宗", "秉风", "曲垣", "肩外俞", "肩中俞", "天窗", "天容", "颧髎", "听宫")
If InStr(1, cell.value, keyword) > 0 Then
If countDict6.Exists(keyword) Then
countDict6(keyword) = countDict6(keyword) + 1
Else
countDict6(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("睛明", "攒竹", "眉冲", "曲差", "五处", "承光", "通天", "络却", "玉枕", "天柱", "大杼", "风门", "肺俞", "厥阴俞", "心俞", "督俞", "膈俞", "肝俞", "胆俞", "脾俞", "胃俞", "三焦俞", "肾俞", "气海俞", "大肠俞", "关元俞", "小肠俞", "膀胱俞", "中膂俞", "白环俞", "上髎", "次髎", "中髎", "下髎", "会阳", "承扶", "殷门", "浮郄", "委阳", "委中", "附分", "魄户", "膏肓", "神堂", "譩譆", "膈关", "魂门", "阳纲", "意舍", "胃仓", "肓门", "志室", "胞肓", "秩边", "合阳", "承筋", "承山", "飞扬", "跗阳", "昆仑", "仆参", "申脉", "金门", "京骨", "束骨", "足通谷", "至阴")
If InStr(1, cell.value, keyword) > 0 Then
If countDict7.Exists(keyword) Then
countDict7(keyword) = countDict7(keyword) + 1
Else
countDict7(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("涌泉", "然谷", "太溪", "大钟", "水泉", "照海", "复溜", "交信", "筑宾", "阴谷", "横骨", "大赫", "气穴", "四满", "中注", "肓俞", "商曲", "石关", "阴都", "通谷", "幽门", "步廊", "神封", "灵墟", "神藏", "彧中", "俞府")
If InStr(1, cell.value, keyword) > 0 Then
If countDict8.Exists(keyword) Then
countDict8(keyword) = countDict8(keyword) + 1
Else
countDict8(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("天池", "天泉", "曲泽", "郄门", "间使", "内关", "大陵", "劳宫", "中冲")
If InStr(1, cell.value, keyword) > 0 Then
If countDict9.Exists(keyword) Then
countDict9(keyword) = countDict9(keyword) + 1
Else
countDict9(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("关冲", "液门", "中渚", "阳池", "外关", "支沟", "会宗", "三阳络", "四渎", "天井", "清冷渊", "消泺", "臑会", "肩髎", "天髎", "天牖", "翳风", "瘈脉", "颅息", "角孙", "耳门", "耳和髎", "丝竹空")
If InStr(1, cell.value, keyword) > 0 Then
If countDict10.Exists(keyword) Then
countDict10(keyword) = countDict10(keyword) + 1
Else
countDict10(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("瞳子髎", "听会", "上关", "颌厌", "悬颅", "悬厘", "曲鬓", "率谷", "天冲", "浮白", "头窍阴", "完骨", "本神", "阳白", "头临泣", "目窗", "正营", "承灵", "脑空", "风池", "肩井", "渊液", "辄筋", "日月", "京门", "带脉", "五枢", "维道", "居髎", "环跳", "风市", "中渎", "膝阳关", "阳陵泉", "阳交", "外丘", "光明", "阳辅", "悬钟", "丘墟", "足临泣", "地五会", "侠溪", "足窍阴")
If InStr(1, cell.value, keyword) > 0 Then
If countDict11.Exists(keyword) Then
countDict11(keyword) = countDict11(keyword) + 1
Else
countDict11(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("大敦", "行间", "太冲", "中封", "蠡沟", "中都", "膝关", "曲泉", "阴包", "足五里", "阴廉", "急脉", "章门", "期门")
If InStr(1, cell.value, keyword) > 0 Then
If countDict12.Exists(keyword) Then
countDict12(keyword) = countDict12(keyword) + 1
Else
countDict12(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("会阴", "曲骨", "中极", "关元", "石门", "气海", "阴交", "神阙", "水分", "下脘", "建里", "中脘", "上脘", "巨阙", "鸠尾", "中庭", "膻中", "玉堂", "紫宫", "华盖", "璇玑", "天突", "廉泉", "承浆")
If InStr(1, cell.value, keyword) > 0 Then
If countDict13.Exists(keyword) Then
countDict13(keyword) = countDict13(keyword) + 1
Else
countDict13(keyword) = 1
End If
End If
Next keyword
For Each keyword In Array("长强", "腰俞", "腰阳关", "命门", "悬枢", "脊中", "中枢", "筋缩", "至阳", "灵台", "神道", "身柱", "陶道", "大椎", "哑门", "风府", "脑户", "强间", "后顶", "百会", "前顶", "囟会", "上星", "神庭", "印堂", "素髎", "水沟", "兑端", "龈交")
If InStr(1, cell.value, keyword) > 0 Then
If countDict14.Exists(keyword) Then
countDict14(keyword) = countDict14(keyword) + 1
Else
countDict14(keyword) = 1
End If
End If
Next keyword
End If
Next cell
' 生成结果字符串
For Each keyword In countDict1.keys
result1 = result1 & keyword & " (" & countDict1(keyword) & "), "
Next keyword
result1 = Left(result1, Len(result1) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict2.keys
result2 = result2 & keyword & " (" & countDict2(keyword) & "), "
Next keyword
result2 = Left(result2, Len(result2) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict3.keys
result3 = result3 & keyword & " (" & countDict3(keyword) & "), "
Next keyword
result3 = Left(result3, Len(result3) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict4.keys
result4 = result4 & keyword & " (" & countDict4(keyword) & "), "
Next keyword
result4 = Left(result4, Len(result4) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict5.keys
result5 = result5 & keyword & " (" & countDict5(keyword) & "), "
Next keyword
result5 = Left(result5, Len(result5) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict6.keys
result6 = result6 & keyword & " (" & countDict6(keyword) & "), "
Next keyword
result6 = Left(result6, Len(result6) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict7.keys
result7 = result7 & keyword & " (" & countDict7(keyword) & "), "
Next keyword
result7 = Left(result7, Len(result7) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict8.keys
result8 = result8 & keyword & " (" & countDict8(keyword) & "), "
Next keyword
result8 = Left(result8, Len(result8) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict9.keys
result9 = result9 & keyword & " (" & countDict9(keyword) & "), "
Next keyword
result9 = Left(result9, Len(result9) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict10.keys
result10 = result10 & keyword & " (" & countDict10(keyword) & "), "
Next keyword
result10 = Left(result10, Len(result10) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict11.keys
result11 = result11 & keyword & " (" & countDict11(keyword) & "), "
Next keyword
result11 = Left(result11, Len(result11) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict12.keys
result12 = result12 & keyword & " (" & countDict12(keyword) & "), "
Next keyword
result12 = Left(result12, Len(result12) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict13.keys
result13 = result13 & keyword & " (" & countDict13(keyword) & "), "
Next keyword
result13 = Left(result13, Len(result13) - 2) ' 移除最后的逗号和空格
For Each keyword In countDict14.keys
result14 = result14 & keyword & " (" & countDict14(keyword) & "), "
Next keyword
result14 = Left(result14, Len(result14) - 2) ' 移除最后的逗号和空格
' 将结果输入到E1、E2、E3单元格
ws.Range("E1").value = result1
ws.Range("E2").value = result2
ws.Range("E3").value = result3
ws.Range("E4").value = result4
ws.Range("E5").value = result5
ws.Range("E6").value = result6
ws.Range("E7").value = result7
ws.Range("E8").value = result8
ws.Range("E9").value = result9
ws.Range("E10").value = result10
ws.Range("E11").value = result11
ws.Range("E12").value = result12
ws.Range("E13").value = result13
ws.Range("E14").value = result14
End Sub
但是当我复制下当前的代码，改了第七个几个汉字后，就报错了
For Each keyword In Array("孔最", "温溜", "梁丘", "地机", "阴郄", "养老", "金门", "水泉", "郄门", "会宗", "外丘", "中都", "阳交", "筑宾", "跗阳", "交信")
If InStr(1, cell.value, keyword) > 0 Then
If countDict7.Exists(keyword) Then
countDict7(keyword) = countDict7(keyword) + 1
Else
countDict7(keyword) = 1
End If
End If
Next keyword
这是报错图片
点调试后显示如图
就很离谱啊
原程序运行的好好的，也是我从ChatGPT好不容易获取一个模板后从1到14一个一个填的啊，这咋就报错呢？
