[已解决]多个TXT文件内容的读取

金樽空对月

如附件内，把名称为1 到4 的TXT文件的内容逐个读取到汇总表的第一个工作表内，排列效果见附件内EXCEL文档。
感谢！

最佳答案

月排行榜 / 总排行榜

爱疯

2015-10-15 16:08

'主程序
Sub test()
    Application.ScreenUpdating = False
    Call test1
    Call test2
End Sub

'清除工作表
Sub test1()
    Dim x
    Application.DisplayAlerts = False
    For Each x In Sheets
        If x.Name <> "Sheet1" Then x.Delete
    Next x
End Sub

'查找文本
Sub test2()
    Dim p, f
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.txt")
    Do While f <> ""
        Call test3(p, f)
        f = Dir
    Loop
End Sub

'文本导入工作表
Sub test3(p, f)
    Dim A
    Open p & f For Input As #1
    A = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
    Close #1

    Sheets.Add after:=Sheets(Sheets.Count)
    Range("a1").Resize(UBound(A) + 1) = Application.Transpose(A)
    Range("a:a").TextToColumns ConsecutiveDelimiter:=True, Space:=True    '按空格分列
    ActiveSheet.Name = f
End Sub

导入.rar (12.13 KB, 下载次数: 21)

2015-10-15 16:06 上传

点击文件名下载附件



这样可以吗

跳转到最佳答案楼层

张雄友

不是已经实现了吗？

金樽空对月

张雄友 发表于 2015-10-14 21:45
不是已经实现了吗？

那只是做了个效果

金樽空对月

张雄友 发表于 2015-10-14 21:45
不是已经实现了吗？

我试着做了一个，没做出来，也不知道就那些格式的数据，能不能办到。

金樽空对月

哪位大神能帮忙弄一下，想得到的效果见附件。

张雄友

金樽空对月 发表于 2015-10-15 08:45
哪位大神能帮忙弄一下，想得到的效果见附件。

一楼代码已能实现，你还想怎么实现？不懂你的意思啊大哥……

金樽空对月

张雄友 发表于 2015-10-15 13:08
一楼代码已能实现，你还想怎么实现？不懂你的意思啊大哥……

我看下，哦，附件上传错误，那个只是提取单个文件的，现在已经更换了。

爱疯

'主程序
Sub test()
    Application.ScreenUpdating = False
    Call test1
    Call test2
End Sub

'清除工作表
Sub test1()
    Dim x
    Application.DisplayAlerts = False
    For Each x In Sheets
        If x.Name <> "Sheet1" Then x.Delete
    Next x
End Sub

'查找文本
Sub test2()
    Dim p, f
    p = ThisWorkbook.Path & "\"
    f = Dir(p & "*.txt")
    Do While f <> ""
        Call test3(p, f)
        f = Dir
    Loop
End Sub

'文本导入工作表
Sub test3(p, f)
    Dim A
    Open p & f For Input As #1
    A = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
    Close #1

    Sheets.Add after:=Sheets(Sheets.Count)
    Range("a1").Resize(UBound(A) + 1) = Application.Transpose(A)
    Range("a:a").TextToColumns ConsecutiveDelimiter:=True, Space:=True    '按空格分列
    ActiveSheet.Name = f
End Sub

导入.rar (12.13 KB, 下载次数: 21)

2015-10-15 16:06 上传

点击文件名下载附件



这样可以吗

金樽空对月

爱疯 发表于 2015-10-15 16:08
'主程序
Sub test()
    Application.ScreenUpdating = False

这样更好啦，感谢！

张雄友

金樽空对月 发表于 2015-10-15 16:29
这样更好啦，感谢！

其实也不是太好。