[已解决][请dsmch老师看看]选择文件时以文本框显示并读取文件

oubaiyas122

      老师好：
       需求如下，谢谢！
       1、让第4行代码，变成以文件框的方式显示，并选择“附件.txt”,然后接着执行后面的代码读取txt的内容。
       2、当文件框打开时，如要选择多个txt的文件。并在excel的不同sheet显示读取文本文件的内容。

Sub Macro1() On Error Resume Next Dim arr(), i&, zf$ Open ThisWorkbook.Path & "\附件.txt" For Input As #1     w = Split(StrConv(InputB(LOF(1), #1), vbUnicode), "---    END") Close #1 ReDim arr(1 To UBound(w), 1 To 2) For i = 0 To UBound(w) - 1     zf = Split(Split(w(i), "IY=")(1), ",")(0)     arr(i + 1, 1) = Mid(zf, 2, Len(zf) - 2)     arr(i + 1, 2) = Split(Split(w(i), " 产品类型  = ")(1), vbCrLf)(0) Next Range("a2").Resize(UBound(arr), 2) = arr End Sub

最佳答案

月排行榜 / 总排行榜

dsmch

2014-9-30 20:35

1. Sub Macro2() '一次性选取多个文本文件
   
2. On Error Resume Next
   
3. Dim arr(), i&, zf$
   
4. With Application.FileDialog(msoFileDialogOpen)
   
5.         .AllowMultiSelect = True
   
6.         .Show
   
7.         For j = 1 To .SelectedItems.Count
   
8.             If Sheets.Count < j Then Sheets.Add after:=Sheets(Sheets.Count)
   
9.             Open .SelectedItems(j) For Input As #1
   
10.                 w = Split(StrConv(InputB(LOF(1), #1), vbUnicode), "---    END")
    
11.             Close #1
    
12.             ReDim arr(1 To UBound(w), 1 To 2)
    
13.             For i = 0 To UBound(w) - 1
    
14.                 zf = Split(Split(w(i), "IY=")(1), ",")(0)
    
15.                 arr(i + 1, 1) = Mid(zf, 2, Len(zf) - 2)
    
16.                 arr(i + 1, 2) = Split(Split(w(i), " 产品类型  = ")(1), vbCrLf)(0)
    
17.             Next
    
18.             Sheets(j).[a1:b1] = Array("IY", "产品类型")
    
19.             Sheets(j).Range("a2").Resize(UBound(arr), 2) = arr
    
20.             Sheets(j).Columns.AutoFit
    
21.         Next
    
22. End With
    
23. End Sub

复制代码

跳转到最佳答案楼层

xdragon

1. Sub test()
   
2.     Dim fn, i%
   
3.     fn = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
   
4.     If IsArray(fn) Then
   
5.        For i = 1 To UBound(fn)
   
6.            Call txt_to_excel(fn(i), i)
   
7.        Next
   
8.     ElseIf fn <> flase Then
   
9.        Call txt_to_excel(fn, 1)
   
10.     End If
    
11. End Sub
    
12. 
    
13. Sub txt_to_excel(Filename, num%)
    
14.    Dim arr(), i&, zf$
    
15.    On Error Resume Next
    
16.    Open Filename For Input As #1
    
17.        w = Split(StrConv(InputB(LOF(1), #1), vbUnicode), "---    END")
    
18.    Close #1
    
19.    ReDim arr(UBound(w), 1)
    
20.    For i = 0 To UBound(w) - 1
    
21.       zf = Split(Split(w(i), "IY=")(1), ",")(0)
    
22.       arr(i, 0) = Mid(zf, 2, Len(zf) - 2)
    
23.       arr(i, 1) = Split(Split(w(i), " 产品类型  = ")(1), vbCrLf)(0)
    
24.    Next
    
25.    If Sheets.Count < num Then Sheets.Add , Sheets(Sheets.Count)
    
26.    With Sheets(num)
    
27.        .Cells.Clear
    
28.        .Range("A2").Resize(UBound(arr, 2)) = arr
    
29.        .Range("A1:B1") = Array("IY", "产品类型")
    
30.     End With
    
31. End Sub

复制代码

oubaiyas122

可能是我说得不清楚，看的人很多。回复的人很少。
我重新说明下问题的需求：
原始的问题是通过读取txt的内容，自动对应到“效果”表里sheet1的A和B列。这个问题已经解决了。因为之前代码是用这样的格式：Open ThisWorkbook.Path & "\附件.txt" For Input As #1来读取txt。每次需要把txt放到固定的文件夹，且txt过多也不方便读取。由此展开如下两个问题：
1、通过点击sheet1里的按钮，打开文件框，手动选择“附件.txt”文件，并读取文件，生成对应的A，B列内容。
2、通过点击sheet1里的按钮，打开文件框，如有多个类似“附件.txt”文件，比如"附件1.txt"，"附件2.txt",需要全部选到，并读取内容，只是每一个txt文件内容，生成在不同的sheet表里，格式都一样，A和B列内容。
这两个问题应该不难吧！

oubaiyas122

xdragon 发表于 2014-9-29 20:50

谢谢你的回答，正在测试中。

oubaiyas122

没有老师回答了么？

dsmch

1. Sub Macro2() '一次性选取多个文本文件
   
2. With Application.FileDialog(msoFileDialogOpen)
   
3.         .AllowMultiSelect = True
   
4.         .Show
   
5.         For i = 1 To .SelectedItems.Count
   
6.             MsgBox .SelectedItems(i)
   
7.         Next
   
8. End With
   
9. End Sub

复制代码

dsmch

1. Sub Macro2() '一次性选取多个文本文件
   
2. On Error Resume Next
   
3. Dim arr(), i&, zf$
   
4. With Application.FileDialog(msoFileDialogOpen)
   
5.         .AllowMultiSelect = True
   
6.         .Show
   
7.         For j = 1 To .SelectedItems.Count
   
8.             If Sheets.Count < j Then Sheets.Add after:=Sheets(Sheets.Count)
   
9.             Open .SelectedItems(j) For Input As #1
   
10.                 w = Split(StrConv(InputB(LOF(1), #1), vbUnicode), "---    END")
    
11.             Close #1
    
12.             ReDim arr(1 To UBound(w), 1 To 2)
    
13.             For i = 0 To UBound(w) - 1
    
14.                 zf = Split(Split(w(i), "IY=")(1), ",")(0)
    
15.                 arr(i + 1, 1) = Mid(zf, 2, Len(zf) - 2)
    
16.                 arr(i + 1, 2) = Split(Split(w(i), " 产品类型  = ")(1), vbCrLf)(0)
    
17.             Next
    
18.             Sheets(j).[a1:b1] = Array("IY", "产品类型")
    
19.             Sheets(j).Range("a2").Resize(UBound(arr), 2) = arr
    
20.             Sheets(j).Columns.AutoFit
    
21.         Next
    
22. End With
    
23. End Sub

复制代码

dsmch

按ctrl一次选取多个文本

oubaiyas122

dsmch 发表于 2014-9-30 20:35

谢谢dsmch老师的详细讲解。解决了我的疑惑。