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
文件内容是这样,就是想提红框内的数据,

导出之后的结果

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
文件内容是这样,就是想提红框内的数据,

导出之后的结果
