这个是可以完美运行的程序
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
这是报错图片
测试文档获取链接:https://wwoh.lanzoue.com/i6B1H0y3oogh
你一点点检查,result7 countDict7 和前面比有没有缺少定义或者写错了。
目测你的数据源有问题吧,一改了数组中的元素,源数据不属于其中了,运行就会报这种错。我是盲猜,如果需要,可以把对应的源数据给我一份,我给你分析一下
根据提供的信息,我无法准确判断代码出现的错误具体原因,也无法提供更具体的报错信息和复制后的代码。这种情况下,建议您通过以下方式来排查错误: 1.检查修改的第七个汉字是否有误,特别是是否将某个字符误删掉或替换成其他字符。可能的情况包括拼写错误、大小写问题、空格或符号错误等等。
2.检查修改后的代码是否引入了其他错误,例如语法错误、括号未关闭、变量未声明、重复定义变量等等。可以尝试逐行调试代码,并用“MsgBox”输出调试信息,以帮助查找错误。
3.检查VBA引用的对象或库文件是否正确,防止出现缺失或版本不匹配的情况。比如有些代码需要引用Microsoft Excel Object Library,如果引用的版本与当前使用的Excel版本不匹配,就会引发错误。
4.建议将错误信息截图,包括代码和错误提示窗口,以便更好地进行跟踪和排查。
5.如果以上方法都不能解决问题,建议在网上查找与该问题相关的解决方案,或向VBA开发者社区求助。可能会得到更专业、更全面的帮助。
可以借鉴下
不要一个一个的去判断是否存在窗口,而是直接循环所有窗口,对特定的进行处理,逻辑是:
Sub x()
Dim wb As Workbook
For Each wb In Workbooks
MsgBox wb.Name
If wb.Name = "att01.csv" Or wb.Name = "att02.csv" Or wb.Name = "att03.csv" Then
wb.Activate
'继续处理
End If
Next wb
End Sub