Sub ImportYJKDataToExcel()
Dim fso As Object, txtStream As Object
Dim ws As Worksheet
Dim paramDict As Object
Dim headerOrder As Variant
Dim currentLine As String
Dim parts() As String
Dim i As Long, j As Long
Dim dataStart As Boolean
Const MAX_LINES As Long = 100000 '安全读取限制
' 初始化设置
Set ws = ThisWorkbook.ActiveSheet
Set paramDict = CreateObject("Scripting.Dictionary")
headerOrder = Array("N", "Mx", "My", "Asxt", "Asxt0", "Vx", "Vy", "Ts", "Asvx", "Asvx0")
' 清空目标工作表
ws.Cells.Clear
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
' 使用文件系统对象高效读取
Set fso = CreateObject("Scripting.FileSystemObject")
Set txtStream = fso.OpenTextFile("E:\12345.txt", 1, False, -1) ' -1=自动检测编码
' 解析数据
dataStart = False
i = 0
Do While Not txtStream.AtEndOfStream And i < MAX_LINES
currentLine = Trim(txtStream.ReadLine)
i = i + 1
' 定位起始标记
If Not dataStart Then
If InStr(currentLine, "柱配筋设计及验算") > 0 Then
dataStart = True
End If
GoTo ContinueLoop
End If
' 结束条件
If Len(currentLine) = 0 Then Exit Do
' 增强型正则解析（避免使用Split）
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "([A-Za-zα-ω]+0?)[=\(\s]*([-+]?\d*\.?\d+)" '匹配参数和数值
If .Test(currentLine) Then
Set matches = .Execute(currentLine)
For Each Match In matches
paramDict(Match.SubMatches(0)) = Match.SubMatches(1)
Next
End If
End With
ContinueLoop:
Loop
' 关闭文件流
txtStream.Close
' 写入表头和数据
For j = 0 To UBound(headerOrder)
ws.Cells(1, j + 1) = headerOrder(j)
ws.Cells(2, j + 1) = paramDict.Item(headerOrder(j))
Next j
' 格式优化
ws.UsedRange.Columns.AutoFit
ws.Rows(1).Interior.ColorIndex = 20
CleanUp:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set fso = Nothing
MsgBox "成功导入" & paramDict.Count & "个参数", vbInformation
Exit Sub
ErrorHandler:
If Err.Number = 53 Then
MsgBox "文件路径不存在：" & vbCrLf & "E:\12345.txt", vbCritical
Else
MsgBox "错误 " & Err.Number & "：" & Err.Description, vbCritical
End If
Resume CleanUp
End Sub
文件内容是这样，就是想提红框内的数据，
导出之后的结果

上个文件样本来测试一下吧，当这么看很难看出问题的所在的，最好能F8看看流程哪步错了