需修改VBA程序读取指定目录HTM文件并提取数据至Excel

需求要点 #

• 遍历C:\Untitled目录下所有.htm文件，读取纯文本内容
• 定位文件中编号为338-232、34k-33k、dj-34的条目
• 提取对应条目里school-后的内容，写入Excel的school列

修改后的完整VBA代码 #

Option Explicit
Sub ExtractSchoolData()
    Dim FileSysObj As Object
    Dim FolderObj As Object
    Dim FileColl As Object
    Dim FileObj As Object
    Dim TextStream As Object
    Dim LineText As String
    Dim TargetNumbers As Variant
    Dim CurrentNumber As String
    Dim SchoolValue As String
    Dim SchoolCol As Integer
    Dim NextRow As Integer
    
    ' 目标编号列表
    TargetNumbers = Array("338-232", "34k-33k", "dj-34")
    ' 指定要读取的文件夹路径
    Const FolderPath As String = "C:\Untitled"
    
    ' 初始化FileSystemObject
    Set FileSysObj = CreateObject("Scripting.FileSystemObject")
    ' 检查文件夹是否存在
    If Not FileSysObj.FolderExists(FolderPath) Then
        MsgBox "指定路径不存在：" & FolderPath, vbExclamation
        Exit Sub
    End If
    
    Set FolderObj = FileSysObj.GetFolder(FolderPath)
    Set FileColl = FolderObj.Files
    
    ' 定位Excel中的school列
    On Error Resume Next
    SchoolCol = Cells.Find(What:="school", LookIn:=xlValues, LookAt:=xlWhole).Column
    On Error GoTo 0
    If SchoolCol = 0 Then
        MsgBox "未找到school列，请先添加表头", vbExclamation
        Exit Sub
    End If
    
    ' 遍历所有文件
    For Each FileObj In FileColl
        ' 筛选.htm文件（不区分大小写）
        If LCase(FileObj.Name) Like "*.htm" Then
            Set TextStream = FileSysObj.OpenTextFile(FileObj.Path, 1) ' 1=只读模式
            CurrentNumber = ""
            SchoolValue = ""
            
            ' 逐行读取文件内容
            Do While Not TextStream.AtEndOfStream
                LineText = Trim(TextStream.ReadLine)
                
                ' 提取当前条目编号
                If Left(LineText, 6) = "number" Then
                    CurrentNumber = Trim(Mid(LineText, 7))
                End If
                
                ' 提取school值，且当前编号在目标列表中
                If Left(LineText, 7) = "school-" And _
                   IsInArray(CurrentNumber, TargetNumbers) Then
                    SchoolValue = Trim(Mid(LineText, 8))
                    ' 找到school列的下一个空行
                    NextRow = Cells(Rows.Count, SchoolCol).End(xlUp).Row + 1
                    ' 写入值
                    Cells(NextRow, SchoolCol).Value = SchoolValue
                    ' 重置，避免重复写入
                    CurrentNumber = ""
                    SchoolValue = ""
                End If
            Loop
            TextStream.Close
        End If
    Next FileObj
    
    MsgBox "数据提取完成！", vbInformation
End Sub

' 辅助函数：检查值是否在数组中
Function IsInArray(SearchVal As String, Arr As Variant) As Boolean
    Dim Element As Variant
    For Each Element In Arr
        If Element = SearchVal Then
            IsInArray = True
            Exit Function
        End If
    Next Element
    IsInArray = False
End Function

关键代码说明 #

1. 目标编号管理：用数组TargetNumbers存储需要匹配的编号，后续新增/修改编号直接修改数组即可
2. 路径与列检查：先验证目标文件夹是否存在，同时定位Excel中的school列，避免运行出错
3. 文件读取逻辑：逐行扫描.htm文件，先记录当前条目编号，当编号在目标列表中时，提取对应的school-后内容
4. 写入Excel：自动找到school列的下一个空行，避免覆盖已有数据

注意事项 #

• 确保你的Excel表格中已经存在表头为school的列
• 若目标文件夹中有无法读取的.htm文件，可在代码中添加错误处理（比如On Error Resume Next）跳过异常文件
• 大文件较多时，可考虑调整读取方式提升效率

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