用vba如何提取多个txt文件数据

应《中华人民共和国网络安全法》要求，自2017年6月1日起，使用互联网服务需进行帐号实名认证。为保障您的百度帐号能够正常使用，请尽快对帐号进行手机号验证，感谢您的理解与支持。

如何用VBA 从TXT文件中提取相关数据输入excel表格？

我的TXT文件结构如下 P000000001987456 C0000000024835410020101103002018000020101102 C0000000034824360020101102002018000020101101 T0000000040000000000000000000000000000000000 解释如下： P000000001987456： 这是整个TXT文件的第一行，7个零后展开

我明白可以用导入数据的形式把TXT文件导入到excel 表格(XLS),但是我还是希望能用VBA来处理，因为我给的例子只是数据的一部分，每行数据还包含很多其它内容，而我只想提取相应的部分。谢谢大家。

xfwxiao | 浏览 6831 次

我有更好的答案

发布于2010-11-10 14:32最佳答案

Public Sub abc()

Dim filename, inputstring As String

Dim i As Integer

Dim data

i = 1

filename = "d:\WYKStxt" '本列TXT文件放在D盘中

Open filename For Input Access Read As #1

Do While Not EOF(1)

Line Input #1, inputstring '读TXT文件一行

data = inputstring

If i <> 1 Then

Cells(i - 1, 1) = Mid(data, 11, 6) '截取从第11个字符后6个字符

Cells(i - 1, 2) = Mid(data, 19, 8) '截取从第19个字符后8个字符

Cells(i - 1, 3) = Mid(data, 29, 6) '截取从第29个字符后6个字符

在多个txt文件的文件夹中新建一个EXCEL，在其VBA中输入ReadTextFiles()，然后运行：

Sub ReadTextFiles()

Dim n As Long, a(), ff As Integer, txt As String, myDir As String, x

Dim myF As String, i As Long

myDir = ThisWorkbookPath & ApplicationPathSeparator

myF = Dir(myDir & "txt")

Do While myF <> ""

ff = FreeFile

Open myDir & myF For Input As #ff

Do While Not EOF(ff)

Line Input #ff, txt

x = Split(txt, "|")

n = n 1

ReDim Preserve a(1 To n)

a(n) = x

Loop

Close #ff

myF = Dir()

Loop

CellsClear

With ThisWorkbookWorksheets("Sheet1")Range("a1")

For i = 1 To UBound(a)

Offset(i - 1)Resize(, UBound(a(i)) 1) = a(i)

Next

End With

End Sub

可以

dim wb as workbook , a&

set wb = getobject("文件的全部路径")

with wb

for a = 1 to wbsheetscount

if sheets(a)name = " 4月份" then

sheets(1)range()copy thisworkbook

activesheetsname = " 名称"

```

```

end with

具体 *** 作需要看数据而行了

Set fs = CreateObject("ScriptingFileSystemObject")

strBomName = fsgetfilename(路径)

Set fs = Nothing

Open strBomDir For Input As #1

Do While Not EOF(1)

intLine = intLine + 1

Line Input #1, strLine

Loop

你可以参考下 数据存在Strline里

用Replace Pioneer按照第一列的内容对第二列累加，详细步骤： 1 ctrl-o打开文本文件atxt 2 ctrl-h打开replace窗口 replace unit选择Line 点击Advanced选项页 在insert begin text输入get_values_all() 在run following at the beginning of replace输入clear_values_all() 在run following for each matched unit输入set_value($match[1],get_value($match[1])+$match[2]); 3 点击Replace即可。 4 ctrl-s保存为btxt

Excel文件格式一致，汇总求和，其他需求自行变通容

汇总使用了字典

Public d

Sub 按钮1_Click()

ApplicationScreenUpdating = False

ActiveSheetUsedRangeClearContents

Cells(1, 1) = "编号"

Cells(1, 2) = "数量"

Set d = CreateObject("scriptingdictionary")

Getfd (ThisWorkbookPath) 'ThisWorkbookPath是当前代码文件所在路径，路径名可以根据需求修改

ApplicationScreenUpdating = True

If dCount > 0 Then

ThisWorkbookSheets(1)[a2]Resize(dCount) = WorksheetFunctionTranspose(dkeys)

ThisWorkbookSheets(1)[b2]Resize(dCount) = WorksheetFunctionTranspose(ditems)

End If

End Sub

Sub Getfd(ByVal pth)

Set Fso = CreateObject("scriptingfilesystemobject")

Set ff = Fsogetfolder(pth)

For Each f In ffFiles

Rem 具体提取哪类文件，还是需要根据文件扩展名进行处理

If InStr(Split(fName, "")(UBound(Split(fName, ""))), "xl") > 0 Then

If fName <> ThisWorkbookName Then

Set wb = WorkbooksOpen(f)

For Each sht In wbSheets

If WorksheetFunctionCountA(shtUsedRange) > 1 Then

arr = shtUsedRange

For j = 2 To UBound(arr)

d(arr(j, 1)) = d(arr(j, 1)) + arr(j, 2)

Next j

End If

Next sht

wbClose False

End If

End If

Next f

For Each fd In ffsubfolders

Getfd (fd)

Next fd

End Sub

我想知道中间白色的是空格还是tab还是啥，有例子吗，TXT文件

————————————————————————————————

其实我还有几个问题，第一是这个txt文件的编码是ANSI还是unicode编码类型可能会影响结果，我试着两种都做了，但是事实上看起来是txt文件，字符集类型不知道，也不太好通过代码去判断，另外就是其实我没明白什么叫提取“1000000后的两行应力数据”,因此我试着把所有数据都提取出来，代码执行后首先会让你选择txt所在的文件夹，然后每个txt会生成一个sheet(以txt命名)并且按照格式提出三列数据。我没有试过一个工作簿可以放下多少个sheet，所以万一txt文件太多我也不知道行不行。具体代码如下，供参考。

————————————————————————————————

ApplicationScreenUpdating = 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("ScriptingFileSystemObject")

Set fdlg = ApplicationFileDialog(msoFileDialogFolderPicker)

xlsc = 1

With fdlg

Title = "请选择数据所在的文件夹"

InitialFileName = ThisWorkbookPath & "\"

If Show = -1 Then

Set xlsp = SelectedItems

End If

End With

If xlsp Is Nothing Then

Else

xlsf = Dir(xlspItem(1) & "\" & "txt")

For Each f In CreateObject("scriptingFileSystemObject")GetFolder(xlspItem(1))Files

If fName 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 = xlspItem(1) & "\" & xlsarr(x)

Set stm = CreateObject("AdodbStream")

stmType = 2

stmMode = 3

stmCharset = "UTF-8"

stmOpen

stmLoadFromFile xlsf

Str = stmreadtext

stmClose

Set stm = Nothing

If InStr(1, Str, "STRESS FXY") = 0 Then

Set stm = CreateObject("AdodbStream")

stmType = 2

stmMode = 3

stmCharset = "Unicode"

stmOpen

stmLoadFromFile xlsf

Str = stmreadtext

stmClose

Set stm = Nothing

End If

Str = Str + " "

SheetsAddName = xlsarr(x)

With ThisWorkbookSheets(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

ApplicationScreenUpdating = True

MsgBox ("时间:" & CStr(Timer - ti))

以上就是关于用vba如何提取多个txt文件数据全部的内容，包括:用vba如何提取多个txt文件数据、如何用vba读取多个txt文件名和txt文件内容写入excel中、EXCEL里VBA，能读取指定的文件里数据吗等相关内容解答，如果想了解更多相关内容，可以关注我们，你们的支持是我们更新的动力！