求vb代码：批量txt导入，一个文本占一个单元格（某个文件夹里有上万个txt，要导入一个excle中）

Question

举例：test文件夹里有
1.text 内容为：
我是number no.1
2.text 内容为：我是number no.2
要求导入一个excle中 A1:1.txt B1:我是number no.1 A2:2.txt B2:我是number no.2

Answer 1

Private Sub Command1_Click()
Dim oxl As Object, owb As Object, ost As Object
Dim d As String, i As Long
Set oxl = CreateObject("Excel.Application")
Set owb = oxl.Workbooks.Add
Set ost = owb.sheets(1)
d = Dir("f:\test\*.txt")
Do Until d = ""
    i = i + 1
    ost.cells(i, 1) = d
    Open "f:\test\" & d For Binary As #1
    ost.cells(i, 2) = Input(LOF(1), #1)
    Close #1
    d = Dir
Loop
owb.saveas "f:\test\test.xls"
owb.Close
oxl.quit
MsgBox "ok"
End Sub

Answer 2

如果每个txt只有一行数据，那么可以这样：

Sub 宏2()
'
' 宏2 宏
'
'
Dim sPath As String
sPath = "E:\编程文件\VB\导入txt到Excel\"
For i = 1 To 10000
    If Dir(sPath & i & ".txt") = "" Then Exit Sub
    ActiveSheet.Range("A" & i).Value = i
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & sPath & i & ".txt", Destination:=Range("$B$" & i))
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 936
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Next i
End Sub

思路：先录制宏手动导入一个Txt文件，适当修改代码即可。

追问

我的txt文件 每个里面不只是一行数据 是好多

追答

更改代码如下：

Sub 宏2()
'
' 宏2 宏
'

'
Dim sPath As String
Dim nR As Long, nT As Long
sPath = "E:\编程文件\VB\导入txt到Excel\"
nR = 1
For i = 1 To 10000
    If Dir(sPath & i & ".txt") = "" Then Exit Sub   '判断文件是否存在
    'ActiveSheet.Range("A" & i).Value = i
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & sPath & i & ".txt", Destination:=Range("$B$" & nR))

        .RowNumbers = False
       '……字数太多受限制了，中间这段代码没复制过来，和上面一样。
        .Refresh BackgroundQuery:=False
    End With
    nT = ActiveSheet.Range("B65535").End(xlUp).Row - nR + 1   '插入了多少行
    ActiveSheet.Range("A" & nR & ":A" & nR + nT - 1).Value = i & ".txt"
    nR = nR + nT
Next i
End Sub

追问

哎呀 我采纳错了… 我怎么财富值转给您呢…

追答

没关系，应该不能转~

Answer 3

这个还是可以实现的 我可以帮你写 留个企鹅

追问

大神百度不让留吧