把TXT文本导入到excel

YANG6815475

导入txt文件软件 最好.rar (7.86 KB, 下载次数: 200)

2013-3-15 17:50 上传

点击文件名下载附件     将[练习题] [VBA特2期]抢1:把TXT文本导入到excel中（参考答案在一楼）中的大部份答案经测试有些能用，有些无法用，均录在此处，因原来的网址不好找，现均录在此处。未说明谁写的，有关VBA问题请对号入座，并向这些提供vBA代码的网友致谢！！！前面可连接该文档，可查明相关情况，恕不一一说明。
   其中，有一段vBA代码本人最欣尝，且在测量、勘察有些用途，所以做成一个计算表格，供大家使用！

Sub b()‘正确
Workbooks.Open ThisWorkbook.Path & "\" & "1.txt"
Columns("A:A").TextToColumns '如果要的话
End Sub


Sub TXT文件写入EXCEL()‘好，适用性强！
    Dim XLAPP As New Application
    Workbooks.OpenText Filename:=ThisWorkbook.Path & "\A.TXT", Space:=True
    ROW1 = Range("A65536").End(xlUp).Row
    COLUMN1 = Range("IV1").End(xlToLeft).Column
    ARR1 = Range(Cells(1, 1), Cells(ROW1, COLUMN1))
    Workbooks("A.TXT").Close FASLE
    Range("A1").Resize(UBound(ARR1), UBound(ARR1, 2)) = ARR1
End Sub


方法一:
Sub TextToSheet1()‘好，适用性强！
    Dim FileName As String
    Dim DateTXT As String
    Dim TArr() As String
    Dim i As Integer
    Dim j As Integer
    FileName = ThisWorkbook.Path & "\A.txt"
    j = 1
    ActiveSheet.Cells.ClearContents
    Open FileName For Input As #1
    Do While Not EOF(1)
        Line Input #1, DateTXT
        TArr = Split(DateTXT, " ")
        For i = 0 To UBound(TArr)
            ActiveSheet.Cells(j, i + 1) = TArr(i)
        Next
        j = j + 1
    Loop
    Close #1
End Sub
'方法二:
Sub TextToSheet2()‘好，适用性强！
    Dim FileName As String
    FileName = "111.txt"
    ActiveSheet.Cells.ClearContents
    Workbooks.OpenText _
        FileName:=ThisWorkbook.Path & "\" & FileName, _
        StartRow:=1, DataType:=xlDelimited, Comma:=True, Space:=True
    With ActiveWorkbook
        With .Sheets(1).Range("A1").CurrentRegion
            ThisWorkbook.ActiveSheet.Range("A1").Resize(.Rows.Count, .Columns.Count).Value = .Value
        End With
        .Close False
    End With
End Sub

'方法三
Sub TextToSheet3()‘勉强可以，显示工具拦？
    ActiveSheet.Cells.ClearContents
    With ActiveSheet.QueryTables.Add( _
        Connection:="TEXT;" & ThisWorkbook.Path & "\A.txt", _
        Destination:=Range("A1"))
        .TextFilePlatform = 936
        .TextFileCommaDelimiter = True
        .Refresh
    End With
End Sub


Sub daoyu()‘可以！
Application.ScreenUpdating = False
Dim filename As String
filename = ThisWorkbook.Path & "/A.TXT"
    Workbooks.OpenText filename:=filename, Space:=True
    arr = Range("a1").CurrentRegion
    Workbooks("A.TXT").Close False
Range("a1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
Application.ScreenUpdating = True
End Sub

Sub 读出2()‘可以！
Dim wbm$, zf$, st, k%, m%, arr()
Application.ScreenUpdating = False
wbm = Dir(ThisWorkbook.Path & "\A.txt")
If wbm = "" Then MsgBox "该文件不存在": Exit Sub
Cells.ClearContents
k = 0
Open ThisWorkbook.Path & "\A.txt" For Input As #1
Do While Not EOF(1)
    k = k + 1
    Line Input #1, zf
    st = Split(zf)
    ReDim Preserve arr(1 To 256, 1 To k)
    For m = 0 To UBound(st)
    arr(m + 1, k) = st(m)
    Next
Loop
Close #1
Range("a1").Resize(UBound(arr, 2), 256) = Application.Transpose(arr)
Cells.Columns.AutoFit
Application.ScreenUpdating = True
MsgBox "数据已读出"
End Sub

Sub myopentext()‘可以！
Workbooks.OpenText Filename:=ThisWorkbook.Path _
            & "\A.txt", startrow:=1, Space:=True, _
            fieldinfo:=Array(Array(1, 1), Array(1, 1))
ActiveWorkbook.Sheets(1).Columns("A:B").AutoFit
End Sub

Sub test()‘不行
     ActiveSheet.QueryTables.Add(Connection:="TEXT;" & ThisWorkbook.Path & "\A.txt", Destination:=Range("A1")).Refresh BackgroundQuery:=False
End Sub

Sub 导入文件()‘可以！
    With ThisWorkbook.Sheets(1).QueryTables.Add(Connection:="text;" & ThisWorkbook.Path & "\A.txt", Destination:=ThisWorkbook.Sheets(1).Range("a1"))
        .TextFileSpaceDelimiter = True
        .Refresh BackgroundQuery:=False
    End With
End Sub

Sub test3()'可以反复提取不同名且不在一个文件中的txt文件，好！
    Dim myFileName As String
    Dim arr1
    myFileName = Application.GetOpenFilename(("Text Files (*.txt), *.txt")) '利用Application的GetOpenFilename方法获取需要导入的文本文件名
    Workbooks.OpenText myFileName, startrow:=1, DataType:=xlDelimited, Space:=True '利用Workbooks的OpenText方法导入Text文件
    arr1 = Range("a1").CurrentRegion '导入的TXT文件会生成一个EXCEL文件，这时候这个EXCEL文件是当前激活的工作薄，生成的工作表是当前的工作表，把当前工作表赋值给数组
    ActiveWorkbook.Close False '关闭打开TXT文件时候生成的EXCEL工作薄
    Range("a1").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr1 '这时候，当前工作簿又变成了原来的工作薄与工作表，将数组赋值给当前工作表即可。
End Sub


本代码适用于与excel同文件夹下的txt文件的导入

Sub test()‘可以！
    Dim myFileName As String, mySheetName As String 'myFileName用于储存文件名，mySheetName用于储存opentext方法生成的表名
    myFileName = "A.txt"
    mySheetName = Replace(myFileName, ".txt", "") '通过replace函数，生成所需的表名
    Workbooks.OpenText ThisWorkbook.Path & "\" & myFileName, startrow:=1, DataType:=xlDelimited, Space:=True'opentext方法导入A.txt文件，从第一行开始，用空格作为分隔符
    With ActiveWorkbook 'opentext方法生成的文件薄
        With .Sheets(mySheetName).Range("A1").CurrentRegion 'opentext方法生成的文件表
            ThisWorkbook.Sheets("sheet1").Range("a1").Resize(.Rows.Count, .Columns.Count).Value = .Value '把生成的文件表的内容赋值给sheet1工作表
        End With
        .Close False '关闭opentext方法生成的文件
    End With
End Sub


无法，错的！
Sub BAIKAISHUI()
    Workbooks.OpenText Filename:=ThisWorkbook.Path & "\A.txt", DataType:=xlFixedWidth
    Sheets("A").Copy Before:=ThisWorkbook.Sheets(1)
    Workbooks("A.TXT").Close
End Sub

hbjyzsf

很好，谢谢，但是表格计算表格在哪

tiger2008

不错，学习了！谢谢！

YANG6815475

hbjyzsf 发表于 2013-9-10 16:26
很好，谢谢，但是表格计算表格在哪

最上面，下载！

wanghx66888

老师拿走了谢谢分享

qq805717515

有n个文件夹，里面有n个txt。想批量转换成excel表格中？怎么解决啊!大神告诉下

xsm1974

先收藏，感谢楼主。