使用VBA提取批量TXT文件固定行的内容

Question

想要请教一下大神，如何批量提取如图中所示txt文件的1000000后的两行应力数据到Excel？txt文件有很多，自己编程小白，请求帮忙，谢谢。

Answer 1

我想知道中间白色的是空格还是tab还是啥，有例子吗，TXT文件
————————————————————————————————
其实我还有几个问题，第一是这个txt文件的编码是ANSI还是unicode?编码类型可能会影响结果，我试着两种都做了，但是事实上看起来是txt文件，字符集类型不知道，也不太好通过代码去判断，另外就是其实我没明白什么叫提取“1000000后的两行应力数据”,因此我试着把所有数据都提取出来，代码执行后首先会让你选择txt所在的文件夹，然后每个txt会生成一个sheet(以txt命名)并且按照格式提出三列数据。我没有试过一个工作簿可以放下多少个sheet，所以万一txt文件太多我也不知道行不行。具体代码如下，供参考。
————————————————————————————————
Application.ScreenUpdating = False
Dim fdlg As FileDialog '
Dim xlsarr()
Dim fso As Object
Dim xlsp As Object
Dim xlsf As String
Dim xlsc As Integer
Dim urc As Integer
Dim nc As Integer
Dim urr As Integer
Dim rt As Integer
Dim ct As Integer
Dim adjn As Integer
Dim levn As Integer
Dim sp As Integer
Dim fs As Integer
Dim nt As String
Dim Str As String
Dim n As Integer
ti = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
Set fdlg = Application.FileDialog(msoFileDialogFolderPicker)
xlsc = 1
With fdlg
.Title = "请选择数据所在的文件夹"
.InitialFileName = ThisWorkbook.Path & "\"
If .Show = -1 Then
Set xlsp = .SelectedItems
End If
End With

If xlsp Is Nothing Then

Else
xlsf = Dir(xlsp.Item(1) & "\" & "*.txt")
For Each f In CreateObject("scripting.FileSystemObject").GetFolder(xlsp.Item(1)).Files
If f.Name Like "*.txt" Then n = n + 1
Next
ReDim xlsarr(1 To n)
End If

Do While xlsf <> ""

If xlsf = "" Then
Exit Do
End If
xlsarr(xlsc) = xlsf
xlsc = xlsc + 1
xlsf = Dir
Loop

For x = LBound(xlsarr) To UBound(xlsarr)
If xlsarr(x) <> "" Then
xlsf = xlsp.Item(1) & "\" & xlsarr(x)
Set stm = CreateObject("Adodb.Stream")
stm.Type = 2
stm.Mode = 3
stm.Charset = "UTF-8"
stm.Open
stm.LoadFromFile xlsf
Str = stm.readtext
stm.Close
Set stm = Nothing
If InStr(1, Str, "STRESS FXY") = 0 Then
Set stm = CreateObject("Adodb.Stream")
stm.Type = 2
stm.Mode = 3
stm.Charset = "Unicode"
stm.Open
stm.LoadFromFile xlsf
Str = stm.readtext
stm.Close
Set stm = Nothing
End If
Str = Str + " "
Sheets.Add.Name = xlsarr(x)
With ThisWorkbook.Sheets(xlsarr(x))
urr = 1
urc = .Range("IV" & urr).End(xlToLeft).Column - 1
nc = 0
sp = InStr(1, Str, "STRESS FXY") + Len("STRESS FXY")
For i = 1 To sp
If fs = 0 Then
fs = 1
End If
If (Asc(Mid(Str, i, 1)) >= 48 And Asc(Mid(Str, i, 1)) <= 57) Or Mid(Str, i, 1) = "." Then
tk = tk + 1
nt = Mid(Str, fs, tk)
Else
tk = 0
End If
If tk = 1 Then
fs = i
ElseIf tk = 0 Then
If Len(nt) > 0 Then
.Cells(urr, urc + 1).Value = CStr(nt)
.Cells(urr, urc + 2).Value = "STRESS FX"
.Cells(urr, urc + 3).Value = "STRESS FY"
.Cells(urr, urc + 4).Value = "STRESS FXY"
urr = 1
urc = .Range("IV" & urr).End(xlToLeft).Column
i = sp + 1
End If
nt = ""
End If
Next i
For i = sp To Len(Str)
If (Asc(Mid(Str, i, 1)) >= 48 And Asc(Mid(Str, i, 1)) <= 57) Or Mid(Str, i, 1) = "." Then
tk = tk + 1
nt = Mid(Str, fs, tk)
Else
tk = 0
End If
If tk = 1 Then
fs = i
ElseIf tk = 0 Then
If Len(nt) > 0 Then
nc = nc + 1
ct = nc Mod 7
Select Case ct
Case 0
levn = 2 * (nc \ 7 - 1)
adjn = 2
ct = 4
Case 1 To 4
levn = 2 * ((nc - ct) \ 7)
adjn = 1
Case 5 To 6
levn = 2 * ((nc - ct) \ 7)
adjn = 2
ct = ct - 3
End Select
rt = urr + levn + adjn
.Cells(rt, ct).Value = CStr(nt)
nt = ""
End If
'nt = ""
End If
Next i
End With
End If
Next x
Application.ScreenUpdating = True
MsgBox ("时间:" & CStr(Timer - ti))追问

公司内网的文件，导不出来，空白部分是tab。

Answer 2

大量文件的话，编程批量处理肯定是最方便的，python差不多十几二十行代码就能解决本回答被网友采纳