如何将大量的txt文件批量转换成对应的excel格式文件

panqiuling

求助：现在有几百个txt格式的文本文件，需要将其全都转换成excel格式的（并不是形成一个excel），并且txt里的数据是以Tab和空格分列的，希望转成的excel格式的时候里面的数据可以按照这些分隔符形成相应的列。网上查了很久只是转换了格式，但是里面的数据并没有识别分隔符形成相应的列呢。求高手指点，如何转换？急急急。。。

小花鹿

没有附件.............................................................................................................

yeminqiang

来关注一下?????????

coolall

楼主的数据可能是保密性很高的txt吧。可以举例说明嘛

panqiuling

coolall 发表于 2017-1-9 10:32
楼主的数据可能是保密性很高的txt吧。可以举例说明嘛

没有保密性，都是网上免费的气象数据。第一次来这发帖，忘了上传数据了。数据里面有一个空格分列的，还有多个连续的空格分列的。这怎么弄？

panqiuling

小花鹿 发表于 2017-1-9 10:17
没有附件............................................................................................ ...

这是几个要转换的示例数据，求指点。

小花鹿

panqiuling 发表于 2017-1-9 12:29
这是几个要转换的示例数据，求指点。

给你段代码，自己修改一下：
Sub test()
Dim thispath As String, mytxt As String, s, tm, br(), i&, j&
thispath = ThisWorkbook.Path & "\"
mytxt = Dir(thispath & "*.txt")
Open thispath & mytxt For Input As #1
tm = Split(StrConv(InputB(LOF(1), #1), vbUnicode), vbCrLf)
Close #1
For i = 0 To UBound(tm)
    s = Split(tm(i), ",")
    If i = 0 Then ReDim br(UBound(tm), UBound(s))
    For j = 1 To UBound(s)
        br(i, j) = s(j)
    Next j
    br(i, 0) = "'" & s(0)
Next i
Sheet3.[a1].Resize(i, j) = br
End Sub

autumnalRain

1. Sub test()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set fso = CreateObject("scripting.filesystemobject")
   
5.         For Each file In fso.getfolder(ThisWorkbook.Path).Files
   
6.            If file.Name Like "*.txt" Then
   
7.                Set mytext = fso.opentextfile(file.Path)
   
8.                mycontent = mytext.readall
   
9.                mytext.Close
   
10.                arr = Split(mycontent, vbCrLf)
    
11.                Set wb = Workbooks.Add
    
12.                wb.Sheets(1).[a1].Resize(UBound(arr, 1)) = arr
    
13.                wb.Sheets(1).[a1].CurrentRegion.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
    
14.                             FieldInfo:=Array(Array(0, 1), Array(5, 1), Array(10, 1), Array(17, 1), Array(23, 1), _
    
15.                             Array(28, 1), Array(31, 1), Array(36, 1), Array(41, 1), Array(48, 1), Array(50, 1)), _
    
16.                             TrailingMinusNumbers:=True
    
17.                ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "" & Split(file.Name, ".")(0) & ".xlsx"
    
18.                ActiveWindow.Close True
    
19.            End If
    
20.         Next file
    
21.     Application.ScreenUpdating =TRUE
    
22.     Application.DisplayAlerts =TRUE
    
23. End Sub

复制代码

autumnalRain

》》》》》》》》》》》》》》》》》》》》》》》》》》》》

wdwhwn

autumnalRain 发表于 2017-1-9 14:23
》》》》》》》》》》》》》》》》》》》》》》》》》》》》

赞！！！！！