[已解决]求大神帮忙！！ 如何用VBA宏将TXT文本数据，提取到sheet表中

dasly123

如何将每一个TXT文本数据，复制到一个sheet表格中，19个TXT文本，就对应有19个sheet子表对应的数据 （TXT文本中数据可能是全数字，或全文字及其它字符）

最佳答案

月排行榜 / 总排行榜

苏子龙

2017-6-27 10:46

1. Sub tt()
   
2.     Dim fso, fp, arr, sh As Worksheet, f, strf, col%, str1$, Firstv$, n&, k%, u%
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set fp = fso.getfolder(ThisWorkbook.Path)
   
5.     Application.DisplayAlerts = False
   
6.     Application.ScreenUpdating = False
   
7.     For Each sh In Sheets
   
8.         If sh.Name <> "Sheet1" Then sh.Delete
   
9.     Next
   
10.      Application.DisplayAlerts = True
    
11.     For Each f In fp.Files
    
12.         If fso.getextensionname(f) = "txt" Then
    
13.             Set strf = fso.opentextfile(f)
    
14.             str1 = strf.ReadAll '&#182;áè&#161;μ&#189;str1
    
15. '            n = strf.Line 'óD&#182;àéù&#184;&#246;&#196;úèY
    
16.             Firstv = Split(fso.getfilename(f), ".")(0) 'txt&#206;&#196;&#188;t&#195;&#251;3&#198;
    
17.             strf.Close
    
18.             arr = Split(str1, vbCrLf)
    
19.             Sheets.Add After:=Sheets(Sheets.Count)
    
20.             With ActiveSheet
    
21.                 .Name = Firstv
    
22.                 .Range("a1").Resize(UBound(arr)) = Application.Transpose(arr)
    
23.                 .Columns("A:A").EntireColumn.AutoFit
    
24.             End With
    
25.         End If
    
26.     Next
    
27.     Set fso = Nothing
    
28.   Application.ScreenUpdating = True
    
29. End Sub

复制代码

略微该下，是否满足要求

跳转到最佳答案楼层

小花鹿

用DIR遍历文本文件，再读取内容，再写入工作表...........................................................

苏子龙

1. Sub tt()
   
2.     Dim fso, fp, arr, sh As Worksheet, f, strf, col%, str1$, Firstv$, n&, k%, u%
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     Set fp = fso.getfolder(ThisWorkbook.Path)
   
5.     Application.DisplayAlerts = False
   
6.     Application.ScreenUpdating = False
   
7.     For Each sh In Sheets
   
8.         If sh.Name <> "Sheet1" Then sh.Delete
   
9.     Next
   
10.      Application.DisplayAlerts = True
    
11.     For Each f In fp.Files
    
12.         If fso.getextensionname(f) = "txt" Then
    
13.             Set strf = fso.opentextfile(f)
    
14.             str1 = strf.ReadAll '&#182;áè&#161;μ&#189;str1
    
15. '            n = strf.Line 'óD&#182;àéù&#184;&#246;&#196;úèY
    
16.             Firstv = Split(fso.getfilename(f), ".")(0) 'txt&#206;&#196;&#188;t&#195;&#251;3&#198;
    
17.             strf.Close
    
18.             arr = Split(str1, vbCrLf)
    
19.             Sheets.Add After:=Sheets(Sheets.Count)
    
20.             With ActiveSheet
    
21.                 .Name = Firstv
    
22.                 .Range("a1").Resize(UBound(arr)) = Application.Transpose(arr)
    
23.                 .Columns("A:A").EntireColumn.AutoFit
    
24.             End With
    
25.         End If
    
26.     Next
    
27.     Set fso = Nothing
    
28.   Application.ScreenUpdating = True
    
29. End Sub

复制代码

略微该下，是否满足要求

大灰狼1976

1. Sub aaa()
   
2. Dim arr(1 To 10000, 1 To 1), F$, brr, j&, sh&
   
3. F = Dir(ThisWorkbook.Path & "\*.txt")
   
4. Do While F <> ""
   
5.   sh = sh + 1
   
6.   Open ThisWorkbook.Path & "" & F For Input As #1
   
7.   Do While Not EOF(1)
   
8.     n = n + 1
   
9.     Line Input #1, x
   
10.     For j = 0 To 2
    
11.       arr(n, 1) = x
    
12.     Next j
    
13.   Loop
    
14.   Close #1
    
15.   F = Dir
    
16.   If sh > Sheets.Count Then Sheets.Add after:=Sheets(Sheets.Count)
    
17.   Sheets(sh).[a1].Resize(n) = arr
    
18.   Erase arr
    
19.   n = 0
    
20. Loop
    
21. End Sub

复制代码

大灰狼1976

1. Sub aaa()
   
2. Dim arr(1 To 10000, 1 To 1), F$, sh&
   
3. F = Dir(ThisWorkbook.Path & "\*.txt")
   
4. Do While F <> ""
   
5.   sh = sh + 1
   
6.   Open ThisWorkbook.Path & "" & F For Input As #1
   
7.   Do While Not EOF(1)
   
8.     n = n + 1
   
9.     Line Input #1, x
   
10.     arr(n, 1) = x
    
11.   Loop
    
12.   Close #1
    
13.   F = Dir
    
14.   If sh > Sheets.Count Then Sheets.Add after:=Sheets(Sheets.Count)
    
15.   Sheets(sh).[a1].Resize(n) = arr
    
16.   Erase arr
    
17.   n = 0
    
18. Loop
    
19. End Sub

复制代码

xuhong1102

新人报道，现在excel能自动打开txt文件，那这个程序有什么用呢？

大灰狼1976

xuhong1102 发表于 2017-7-3 09:59
新人报道，现在excel能自动打开txt文件，那这个程序有什么用呢？

批量处理。