多个TXT文档导入到一个sheet中出错

vba789

多个TXT文档导入.rar (9.09 KB, 下载次数: 14)

2020-2-19 18:14 上传

点击文件名下载附件

Sub 导入()
Dim mypath$, myfile$, fn%
mypath = ThisWorkbook.Path & "\"
myfile = Dir(mypath & "*.txt")
fn = FreeFile
Sheet1.Cells.ClearContents
Do While myfile <> ""
  Open mypatn & myfile For Input As #fn
     s = Split(StrConv(InputB(LOF(fn), fn), vbUnicode), vbCrLf)
  Close #fn
  i = i + 1
  Cells(i, 1).Resize(UBound(s), 1) = Application.Transpose(s)
  myfile = Dir
Loop
End Sub
提示未找到文件，请老师指教

gbgbxgb

open mypatn 中，mypatn是什么东东？强制变量声明语句为什么不用？!!!!!

vba789

谢谢2楼，改了，也没达到想要的效果，
调试了很多次，都没整好，
结果是：TXT文档是各小组上传的合计数，按文档序号排序导入到sheet1里合计汇总，
求帮助

liulang0808

s = Split(StrConv(InputB(LOF(fn), fn), vbUnicode), vbCrLf)
用这个，需要先看下文件编码方式的，楼主的文本编码方式不是unicode，而是utf-8。有可能出现乱码的
Sub 导入()
Dim mypath$, myfile$, fn%
mypath = ThisWorkbook.Path & "\"
myfile = Dir(mypath & "*.txt")
fn = FreeFile
Sheet1.Cells.ClearContents
Do While myfile <> ""
  Open mypath & myfile For Input As #fn
     s = Split(StrConv(InputB(LOF(fn), fn), vbUnicode), vbCrLf)
  Close #fn
  i = i + 1
  Cells(i, 1).Resize(UBound(s) + 1, 1) = Application.Transpose(s)
  myfile = Dir
Loop

End Sub

lss001

Sub xmlhttpread()
   Dim FileName, ar, xx, y, i: [a:iv] = ""
   Set xx = CreateObject("Microsoft.XMLHTTP")
   FileName = Dir(ThisWorkbook.Path & "\*.txt")
   Do Until Len(FileName) = 0
       y = xx.Open("Get", ThisWorkbook.Path & "\" & FileName, False)
       xx.send: y = xx.responseText
       ar = Application.Transpose(Split(y, vbCrLf))
       i = i + 1: Cells(1, i).Resize(UBound(ar)) = ar
       FileName = Dir
   Loop
End Sub

taller

多个文本文件导入工作表，直接使用Power Query功能就可以了，不需要任何代码

vba789

liulang0808 发表于 2020-2-19 20:58
s = Split(StrConv(InputB(LOF(fn), fn), vbUnicode), vbCrLf)
用这个，需要先看下文件编码方式的，楼主的 ...

Sub 合计汇总()
Dim mypath$, myfile$
Dim j%, i%, arr, brr, crr(1 To 44, 1 To 6)  '() As String
mypath = ThisWorkbook.Path & "\"
myfile = Dir(mypath & "\*.txt")
On Error Resume Next
Do While myfile <> ""
  Open mypath & myfile For Input As #1
     arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
     For i = 0 To UBound(arr)
     'If arr(i) <> "" Then
       If Len(Trim(arr(i))) <> 0 Then
        'brr = Split(arr(i), ",")
         brr = Split(Trim(arr(i)), ",")
        m = 0
        m = m + 1
         For j = 0 To UBound(brr)
        crr(m, j + 1) = brr(j)
      Next
       End If
  Next
        With Worksheets("sheet1")
    j = 0
    For Each x In Array(3, 4, 6, 7)
      j = j + 1
        Cells(3, x).Resize(UBound(crr), 1) = Application.Index(crr, 0, j)
         Next
         End With
         Close #1
myfile = Dir
Loop
MsgBox "ok"
End Sub
****
首先感谢版主一直以来的热心帮助，我调试了好久，导入后全部在一行里，我要的结果是导入到各小组，附件我重新上传

vba789

多个TXT文档导入.rar (12.51 KB, 下载次数: 2)

2020-2-22 10:15 上传

点击文件名下载附件

一把小刀闯天下

vba789 发表于 2020-2-22 10:15

Option Explicit

Sub test()
  Dim arr, pth, f, m, pos, t, i, j, max
  pth = ThisWorkbook.Path & "\"
  f = Dir(pth & "*.txt")
  pos = Array(2, 3, 5, 6)
  ReDim brr(99, 1 To 6)
  Do While f <> ""
    m = Val(Left(Right(f, 6), 2))
    If max < m Then max = m
    Open pth & f For Input As #1
    arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbNewLine)
    Close #1
    For i = 0 To UBound(arr, 1)
      t = Split(arr(i), ",")
      For j = 0 To UBound(t)
        brr(m, pos(j)) = brr(m, pos(j)) + Val(t(j))
      Next
    Next
    f = Dir
  Loop
  For i = 1 To max
    For j = 0 To UBound(pos)
      brr(0, pos(j)) = brr(0, pos(j)) + brr(i, pos(j))
    Next
    brr(i, 1) = brr(i, 2) + brr(i, 3)
    brr(0, 1) = brr(0, 1) + brr(i, 1)
    brr(i, 4) = brr(i, 5) + brr(i, 6)
    brr(0, 4) = brr(0, 4) + brr(i, 4)
  Next
  [b2].Resize(max + 1, UBound(brr, 2)) = brr
End Sub

vba789

一把小刀闯天下 发表于 2020-2-22 10:51
Option Explicit

Sub test()

你做出来我看懂了，自己做就是迷宫，非常感谢楼上各位