Question

从多个tXt文件导入数据到excel中，如何修改VBA代码，选取不同的文件

我在excel中用录制宏的办法，录了一个宏，但是这个宏里面的代码开头读取文件的地方是我录的时候那个文件，此外还有很多需要录入的文件呢，怎么能够把其他的文件也录进去，就是在宏执行的时候能选取文件或者一次就能按先后顺序把一个文件夹所有txt数据录进去，文件名都类似ap1932.txt 后面的是ap1933一直到ap2010，要求这些数据排在一个excel表里，宏代码如下，如何修改

Sub 导入数据()
'
' 导入数据 Macro
' 宏由 admin 录制，时间: 2011-11-25
'

'
With ActiveSheet.QueryTables.Add(Connection:="TEXT;D:\data\ap1932.txt", _
Destination:=Range("A1"))
.Name = "ap1932"
.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
End Sub

Answer 1

这个你试试
Sub 导入数据()
'修改这几句为
for Y=1932 to 2010
a$="Connection:="TEXT;D:\data\ap" & cstr(Y) & ".txt"
With ActiveSheet.QueryTables.Add(a$, Destination:=Range("A1"))
.Name = "ap" & cstr(Y)

.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

'还有这句
next Y

End Sub

Answer 2

'按照你录制的代码更改，已验证可以直接使用
Public Sub dbhb()
Dim FilesToOpen
Dim x As Integer
'Sheets.Add.Name = "空表"

On Error GoTo ErrHandler
Application.ScreenUpdating = False

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

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

x = 1

While x <= UBound(FilesToOpen)
sr = "TEXT;" & FilesToOpen(x)
Sheets.Add
With ActiveSheet.QueryTables.Add(Connection:=sr, _
Destination:=Range("A1"))
.Name = "ap1932"
.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
Wend

ExitHandler:
Application.ScreenUpdating = True
Exit Sub

ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub

Answer 3

手机登陆：UBBUBB．cσm

Answer 4

楼上正解··