求助！！！VBA整理txt文件数据到excel

一把小刀闯天下

koy4134 发表于 2018-6-11 13:20
天下兄，有个问题向您请教，这段代码只能一个文件一个文件的处理，如果处理文件夹里的多个txt文件需要怎 ...

'假设文件结构还是正确的，未作错误处理

Option Explicit

Sub test()
  Dim arr, mark, i, j, k, n, t, max, a, b, brr, filename(), ii
  mark = Split("servedIMSI accessPointNameNI servedIMEISV ECI")
  If Not getfilename(ThisWorkbook.Path, filename, ".txt") Then MsgBox "!": Exit Sub
  ReDim crr(1 To Rows.Count, 1 To UBound(mark) + 1)
  For ii = 1 To UBound(filename)
    Open filename(ii) For Input As #1
    arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), "PGWRecord")
    Close #1
    For i = 1 To UBound(arr)
      brr = Split(arr(i), vbNewLine)
      For j = 0 To UBound(brr)
        If InStr(brr(j), mark(UBound(mark))) Then b = j: Exit For
      Next
      n = n + 1: a = n
      For j = 0 To UBound(mark)
        For k = 0 To b
          If InStr(brr(k), mark(j)) Then
            t = Replace(brr(k), Space(1), vbNullString)
            crr(n, j + 1) = Replace(t, mark(j) & "=", vbNullString)
          End If
      Next k, j
      For j = b + 1 To UBound(brr)
        If InStr(brr(j), mark(UBound(mark))) Then
          n = n + 1
          t = Replace(brr(j), Space(1), vbNullString)
          crr(n, UBound(mark) + 1) = Replace(t, mark(UBound(mark)) & "=", vbNullString)
          For k = 0 To UBound(mark) - 1: crr(n, k + 1) = crr(a, k + 1): Next
        End If
  Next j, i, ii
  For i = 1 To n
    crr(i, UBound(crr, 2)) = Replace(crr(i, UBound(crr, 2)), "H'", vbNullString)
  Next
  With [a2]
    .Resize(Rows.Count - 1, UBound(crr, 2)).ClearContents
    If n > 0 Then .Resize(n, UBound(crr, 2)) = crr
  End With
  If n = 0 Then Exit Sub
  Dim dic, m
  Set dic = CreateObject("scripting.dictionary")
  For i = 1 To n
    t = crr(i, 1)
    For j = 2 To UBound(crr, 2): t = t & "|" & crr(i, j): Next
    If Not dic.exists(t) Then
      dic(t) = vbNullString
      m = m + 1
      For j = 1 To UBound(crr, 2): crr(m, j) = crr(i, j): Next
    End If
  Next
  With [f2]
    .Resize(Rows.Count - 1, UBound(crr, 2)).ClearContents
    If m > 0 Then .Resize(m, UBound(crr, 2)) = crr
  End With
End Sub

Function getfilename(pth, filename, mark) As Boolean
  Dim f, n
  pth = pth & IIf(Right(pth, 1) = "\", "", "\")
  f = Dir(pth & "*.*")
  Do Until 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

koy4134

一把小刀闯天下 发表于 2018-6-11 13:42
'假设文件结构还是正确的，未作错误处理

Option Explicit

谢谢天下兄的帮助！！！