现在有大量txt文件要导入excel，要求每个文件一个she...-excel宏 导入txt,excel如何导入宏

Public Sub dbhb()
Dim FilesToOpen
Dim x As Integer
'Sheets.Add.Name = "空表"

On Error GoTo ErrHandler
Application.ScreenUpdating = False

FilesToOpen = Application.GetOpenFilename _
(FileFilter:="MicroSoft Excel文件7a64e78988e69d83338(*.txt),*.txt", _
MultiSelect:=True, Title:="要合并的文件")

If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "没有选中文件"
GoTo ExitHandler
End If

x = 1
u = 1
While x <= UBound(FilesToOpen)
cd = 1
lj = FilesToOpen(x)
33
If InStr(Right(FilesToOpen(x), cd), "\") Then
GoTo 44
Else
cd = cd + 1
GoTo 33
End If
44

mz = Mid(FilesToOpen(x), (Len(FilesToOpen(x)) - cd + 2), cd - 5) & u

sr = "TEXT;" & lj
With ActiveSheet.QueryTables.Add(Connection:=sr, _
Destination:=Range("A" & u))
.Name = mz
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 936
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = True
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = True
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With

x = x + 1
u = Range("A1").End(xlDown).Row

Wend

ExitHandler:
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
将多个TXT文件导入到一个工作表里。
能直接打开对话框让你选TXT取文件，不足之处在于你选择的第一个文件将在最后导入。

vba代码如下636f7079e799bee5baa6e79fa5e98193365：

Sub import_Data()
Dim my_Link, my_Doc, My_text As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
.AllowMultiSelect = False
my_Link = .SelectedItems(1)
End With

my_Doc = Dir(my_Link & "\" & "*.txt")

Dim my_Row As Single

Do While Len(my_Doc) <> 0
my_Row = 1
Worksheets.Add
ActiveSheet.Name = Left(my_Doc, Len(my_Doc) - 4)
Open my_Link & "\" & my_Doc For Input As #1

Do While Not EOF(1)

Line Input #1, My_text

Cells(my_Row, 1) = Split(My_text, " ")(0)
Cells(my_Row, 2) = Split(My_text, " ")(UBound(Split(My_text)))
my_Row = my_Row + 1
Loop

Close #1
my_Doc = Dir
Loop

End Sub

假设你所有的文本文件都在“D:\text”目录下，我们只处理.txt文件。

步骤1：导出文件列表
点xp系统的开始菜单，点“运行”命令，输入cmd再回车，进入命令窗口，输入

命令 dir D:\text\*.txt /b /on > c:\list.txt ,回车。现在在c:盘下会有个list文件，包含要处理de文件的文件名。

步骤2：运行下面代码。
Option Explicit
Public Const sPath As String = "D:\text" '请改为你的txt所在的7a686964616fe4b893e5b19e332路径
Public FileName() As String '要处理的文件名
Public MyString() As String '从text中读取内容

Sub ReadFile()
Dim getLine '每次读取一行数据
Dim i%, t%, k%

i = FreeFile
Open "c:\list.txt" For Input As #i ' 打开输入文件。
Do While Not EOF(i)
Input #i, getLine '将数据读入变量。
t = t + 1
Loop
k = t - 1
ReDim FileName(k), MyString(k)
t = 0
Seek #i, 1 '设置文件的第一条记录
Do While Not EOF(i)
Input #i, FileName(t)
FileName(t) = sPath & "\" & FileName(t)
t = t + 1
Loop
Close #i ' 关闭文件。

'读取txt内容到本excel表格
For t = 0 To k
i = FreeFile
Open FileName(t) For Input As #i
Do While Not EOF(i)
Input #i, getLine
MyString(t) = MyString(t) & vbNewLine & getLine
Loop
Close #i
With ThisWorkbook.Sheets(1)
.Cells(t + 1, 1) = FileName(t)
.Cells(t + 1, 2) = Right(MyString(t), Len(MyString(t)) - 2)
End With
Next t

End Sub

Sub 打开文件()
ActiveSheet.Unprotect
Hs = 5
He = Cells(65536, 2).End(xlUp).Row
If He >= Hs Then Rows(Hs & ":" & He).Delete Shift:=xlUp
'----------------
文件格式 = "*.file ,*.*"
读入文件 = Application.GetOpenFilename(Filefilter:=文件格式)
If 读入文件 = False Then Exit Sub
长度 = Len(读入文件)
For I = 长度 - 1 To 1 Step -1
If Mid$(读入文件, I, 1) = "\" Then
文件夹 = Left$(读入文件, I)
文件名 = Mid$(读入文件, I + 1, 长度 - I + 1)
Exit For
End If
Next
文件后缀 = LCase(Right$(文件名, 3))
If 文件后缀 <> "csv" And 文件后缀 <> "txt" And 文件后缀 <> "tab" And 文件后缀 <> "xls" Then
MsgBox "数据文件名称不正确！只能读取【TXT】、【CSV】、【XLS】文件！！"
Exit Sub
End If
Cells(3, 3) = 文件夹
工作簿 = ActiveWorkbook.Name
'------------------
文件名 = "*.xls"
ActiveSheet.Unprotect
H = Hs
文件 = Dir(文件夹 & 文件名)
Do While Len(文件) > 0
If 工作簿 <> 文件 Then
Cells(H, 3) = 文件
Cells(H, 2) = H - Hs + 1
H = H + 1
End If
文件 = Dir()
Loop
ActiveSheet.Protect
'------------------
Call 导入数据
End Sub
Sub 导入数据()
Application.ScreenUpdating = False
Set 函数调用e69da5e6ba90e799bee5baa6e997aee7ad94331 = Application.WorksheetFunction
Dim 项目(1 To 10), 结果(1 To 10)
Hs = 5
He = Cells(65536, 2).End(xlUp).Row
If He < Hs Then Exit Sub
文件夹 = Cells(3, 3)
'----------------
Sheets("汇总").Select
HHs = 2
HHe = Cells(65536, 1).End(xlUp).Row
If HHe >= HHs Then Rows(HHs & ":" & HHe).Delete Shift:=xlUp
HH = HHs
'----------------
For L = 3 To 12
项目(L - 2) = Cells(1, L)
Next
'----------------
For H = Hs To He
文件名 = Sheets("目录").Cells(H, 3)
Cells(HH, 1) = H - Hs + 1
Cells(HH, 2) = Left$(文件名, Len(文件名) - 4)
Workbooks.OpenText Filename:=文件夹 + 文件名
Sheets("page 2").Select
For LLL = 1 To 256
If 函数调用.CountIf(Range(Cells(1, LLL), Cells(1000, LLL)), "检查结果") > 0 Then Exit For
Next
For I = 1 To 5
For HHH = 1 To 1000
If 函数调用.CountIf(Range(Cells(HHH, 1), Cells(HHH, 256)), 项目(I)) > 0 Then Exit For
Next
结果(I) = Cells(HHH, LLL)
Next
Sheets("page 5").Select
For LLL = 1 To 256
If 函数调用.CountIf(Range(Cells(1, LLL), Cells(1000, LLL)), "检查结果") > 0 Then Exit For
Next
For I = 6 To 10
For HHH = 1 To 1000
If 函数调用.CountIf(Range(Cells(HHH, 1), Cells(HHH, 256)), 项目(I)) > 0 Then Exit For
Next
结果(I) = Cells(HHH, LLL)
Next
ActiveWindow.Close
Application.ScreenUpdating = True
For LL = 3 To 12
Cells(HH, LL) = 结果(LL - 2)
Next
HH = HH + 1
Application.ScreenUpdating = False
Next
End Sub