Excel VBA英文文本搜索代码适配日文文本及编码问题求助

问题分析 #

原代码使用FileSystemObject.OpenTextFile读取文本文件，该方法默认采用系统编码（日文系统多为Shift-JIS），无法正确解析UTF-8编码的日文字符，导致读取后文本乱码、后续搜索匹配失效，核心问题是缺少对UTF-8编码的明确支持。

修改方案 #

改用ADODB.Stream对象读取文件，该对象可直接指定UTF-8编码，确保日文字符正确解析，同时保留原有的搜索逻辑和结果输出功能。

修改后的完整代码 #

Global searchallfiles As Integer

Public Type SearchResults
    LineNumber As Long
    CharPosition As Long
    StrLen As Long
    s As String
End Type

Function GetSearchResults(FileFullName As String, FindThis As String, Optional CompareMethod As VbCompareMethod = vbBinaryCompare) As SearchResults()
    Dim stream As Object
    Dim allText As String
    Dim lines() As String
    Dim l As Long, pos As Long, sr As SearchResults, ret() As SearchResults, i As Long
    
    ' 初始化ADODB.Stream读取UTF-8文件
    Set stream = CreateObject("ADODB.Stream")
    With stream
        .Charset = "UTF-8"
        .Open
        .LoadFromFile FileFullName
        allText = .ReadText
        .Close
    End With
    Set stream = Nothing
    
    ' 统一换行符格式，兼容Windows和Unix文本
    allText = Replace(allText, vbCrLf, vbLf)
    lines = Split(allText, vbLf)
    
    ' 遍历每行执行搜索
    For l = LBound(lines) To UBound(lines)
        If Trim(lines(l)) <> "" Then
            pos = 1
            Do
                pos = InStr(pos, lines(l), FindThis, vbTextCompare)
                If pos > 0 Then
                    sr.CharPosition = pos
                    sr.LineNumber = l + 1 ' 行号从1开始计数
                    sr.s = lines(l)
                    sr.StrLen = Len(FindThis)
                    
                    ' 写入Sheet4的逻辑保持原功能
                    LastColumnofsheet4Real = Sheet4.Cells(searchallfiles, Columns.Count).End(xlToLeft).Column
                    Sheet4.Cells(searchallfiles, LastColumnofsheet4Real + 1).Value = sr.LineNumber
                    Sheet4.Cells(searchallfiles, LastColumnofsheet4Real + 2).Value = sr.s
                    
                    ' 保存结果到数组
                    ReDim Preserve ret(i)
                    ret(i) = sr
                    i = i + 1
                    
                    pos = pos + 1
                End If
            Loop Until pos = 0
        End If
    Next l
    
    GetSearchResults = ret
End Function

Sub MyTextStringSearch()
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    Dim MySearch() As SearchResults, i As Long
    Dim searchstringtxt As String
    Dim LastofTextFilelist As Long
    
    searchstringtxt = Sheet1.Cells(6, 4).Value
    LastofTextFilelist = Sheet4.Range("B" & Rows.Count).End(xlUp).Row
    
    For searchallfiles = 2 To LastofTextFilelist
        MySearch = GetSearchResults(Sheet4.Cells(searchallfiles, 2).Value, searchstringtxt)
    Next searchallfiles
    
    ' 恢复界面设置
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

关键修改说明 #

• 编码支持：通过ADODB.Stream的.Charset = "UTF-8"属性，强制以UTF-8编码读取文件，解决日文字符乱码问题。
• 换行兼容：统一将vbCrLf替换为vbLf后分割行，避免因不同系统换行格式导致的行号计数错误。
• 界面恢复：在子过程末尾添加恢复Excel界面设置的代码，避免影响后续操作。

内容的提问来源于stack exchange，提问作者Gaurav