批量dat数据文件处理

jiumengrunian

我有一批dat数据，想快速的导入一个excel里，一个一个导入速度太慢。求各位大侠帮忙指教一下如何快速批量的导入。
这里将一部分原始数据上传，只有第四行的数据就可以，望高手指点。谢谢！

wlmhit903

大概就是自动打开一个dat，复制数据，粘贴到表格，关闭dat，再打开下一个，循环。。。是这样吧？要把所有的dat导入到一个excel表里还是各自保存到不同的文件里？

duquancai

手机，看不了附件。用二进制打开。

jiumengrunian

wlmhit903 发表于 2018-8-20 17:40
大概就是自动打开一个dat，复制数据，粘贴到表格，关闭dat，再打开下一个，循环。。。是这样吧？要把所有的 ...

导入到一个excel里，可以吗。大神。

jiumengrunian

duquancai 发表于 2018-8-20 20:32
手机，看不了附件。用二进制打开。

什么意思呀？

一把小刀闯天下

Option Explicit

Sub test()
  Dim filename(), i, m, arr
  If Not getfilename(filename, ThisWorkbook.Path, ".dat") Then MsgBox "!": Exit Sub
  ReDim brr(1 To Rows.Count, 1 To 1)
  For i = 1 To UBound(filename)
    Open filename(i) For Input As #1
    arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbNewLine)
    Close #1
    If UBound(arr) > 2 Then
      m = m + 1: brr(m, 1) = arr(3)
    Else
      Debug.Print filename(i)
    End If
  Next
  With [a:a]
    .ClearContents
    If m > 0 Then .Resize(m) = brr
  End With
End Sub

Function getfilename(filename, pth, mark) As Boolean
  Dim f, n
  If Right(pth, 1) <> "\" Then pth = pth & "\"
  f = Dir(pth & "*.*")
  Do While Len(f) > 0
    If LCase(Right(f, Len(mark))) = LCase(mark) Then
      n = n + 1: ReDim Preserve filename(1 To n)
      filename(n) = pth & f
    End If
    f = Dir
  Loop
  If n > 0 Then getfilename = True
End Function

jiumengrunian

一把小刀闯天下 发表于 2018-8-21 09:00
Option Explicit

Sub test()

大神，这个代码往哪里写，或者怎么用，我不太懂。可以详细点吗。

jiumengrunian

一把小刀闯天下 发表于 2018-8-21 09:00
Option Explicit

Sub test()

大神，问题描述错了，应该是所有行数据都要。

一把小刀闯天下

'稍作修改，自己再测试一下

Option Explicit

Sub test()
  Dim filename(), i, j, k, m, arr, pos
  If Not getfilename(filename, ThisWorkbook.Path, ".dat") Then MsgBox "!": Exit Sub
  ReDim brr(1 To Rows.Count, 1 To 1)
  For i = 1 To UBound(filename)
    Open filename(i) For Input As #1
    arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbNewLine)
    Close #1
    pos = 0
    For j = UBound(arr) To 0 Step -1 '去除文件尾空行
      If Len(arr(j)) Then pos = j: Exit For
    Next
    For j = 0 To pos: m = m + 1: brr(m, 1) = arr(j): Next
  Next
  With [a:a]
    .ClearContents
    If m > 0 Then .Resize(m) = brr
  End With
End Sub

Function getfilename(filename, pth, mark) As Boolean
  Dim f, n
  If Right(pth, 1) <> "\" Then pth = pth & "\"
  f = Dir(pth & "*.*")
  Do While Len(f) > 0
    If LCase(Right(f, Len(mark))) = LCase(mark) Then
      n = n + 1: ReDim Preserve filename(1 To n)
      filename(n) = pth & f
    End If
    f = Dir
  Loop
  If n > 0 Then getfilename = True
End Function

fxl447098457

power query也很方便。Folder.Files()函数再机上Csv.Document()函数可以搞定。