Xử lý tập tin .txt sau đó gộp các tập tin thành một File sử dụng VBA. (3 người xem)

  • Thread starter Thread starter th7
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
th7

th7

Thành viên thường trực
Tham gia
3/3/15
Bài viết
215
Được thích
52
Giới tính
Nam
Chào các Bạn,
Mình có một rất nhiều files.txt và muốn gộp lại thành một files, các tập tin này là do phần mềm máy bên mình tự động xuất ra và theo một kiểu định dạng chung,
Trước khi gộp lại thì mình cần xử lý file.txt này và chỉ lấy các thông tin cần thiết,
Mình có đính kèm hai tập tin (.txt) và một file Excel kết quả mong muốn,
Các Bạn xem qua nếu có ý gì chưa rõ, mình bổ xung thêm.
Cảm ơn.
 

File đính kèm

Chào các Ban,
Mình xin bổ xung thêm thông tin, Liên quan tới bài viết này, trước đây mình có gửi bài viết "Trích lọc dữ liệu sử dụng Code VBA"
Bài này Bạn HieuCD có hỗ trợ mình và đã hoàn thành, lấy được nội dung và trích xuất ra,
Do công việc nên giờ từ các tập tin .txt mình cần phải tổng hợp lại như file "all in one" ở trên, Các bạn xem qua Code VBA của bạn HieuCD nha,
xem xem mình có liên kết được gì không

Mã: 
Sub Main()
  Dim sArr As Variant, dArr As Variant, Res As Variant, s As Variant
  Dim ProName As String, Productname As String, str As String, tmp As String, FilesToOpen As String
  Dim i As Long, fR As Long, nR As Long, k As Long, ik As Long, j As Byte
  Dim Chk As Boolean
  Chk = Application.FileDialog(msoFileDialogFilePicker).Show
  If Not Chk Then Exit Sub
  FilesToOpen = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1)
  sArr = ImportTextToExcel(FilesToOpen)

  dArr = Range("B7:H8").Value
  ReDim Res(1 To UBound(sArr), 1 To 7)
  For j = 1 To 6
    Res(1, j) = dArr(1, j): Res(2, j) = dArr(2, j)
  Next j
  Res(2, 7) = dArr(2, 7)
  ''Res(1, 2) = "1" & sArr(1, 1)
  Productname = Split(sArr(1, 1), ".")(0)
  Res(2, 1) = "Program Name: " & "1" & Productname
  Res(2, 6) = "No. of comp.ts"
  Res(2, 4) = "Simulate time(s)"
  'Res(1, 1) = "F/R P."
  'Res(1, 2) = "Comp.t Name"
  'Res(1, 3) = "Placement ID"
  'Res(1, 4) = "Description"
  'Res(1, 5) = "Feeder Type"
  'Res(1, 6) = "Comp.t pitch"
  ''Res(1, 7) = "Qty."
 
 
  With CreateObject("scripting.dictionary")
    For i = 1 To UBound(sArr)
      If sArr(i, 1) = "Feeder Position Number" Then fR = i + 1: Exit For
    Next i
    k = 2
    For i = fR To UBound(sArr)
      If sArr(i, 1) <> "" Then
      k = k + 1
      If sArr(i, 1) <> "Feeder Position Number" Then
        Key = sArr(i, 2)
        .Item(Key) = k
        Res(k, 1) = sArr(i, 1)
        s = Split(Key, " ")
        Res(k, 2) = s(1)
        Res(k, 4) = s(0)
        Res(k, 5) = Mid(sArr(i, 3), 3, Len(sArr(i, 3)))
        Res(k, 6) = Split(sArr(i, 4), " ")(0)
      Else
        For j = 1 To 6
          Res(k, j) = dArr(1, j)
        Next j
        'Res(k, 2) = "2" & sArr(1, 1)
        Res(k, 1) = "Program Name: " & "2" & Productname
        Res(k, 6) = "No. of comp.ts"
        Res(k, 4) = "Simulate time(s)"
        
        nR = k
      End If
      End If
    Next i
  
    For i = 1 To UBound(sArr)
      If sArr(i, 1) = "Placement ID" Then fR = i + 1: Exit For
    Next i
    For i = fR To UBound(sArr)
      If sArr(i, 1) = "Feeder Position Number" Then Exit For
      Key = sArr(i, 2)
      If .exists(Key) Then
        ik = .Item(Key)
        Res(ik, 7) = Res(ik, 7) + 1
        If ik < nR Then Res(2, 7) = Res(2, 7) + 1 Else Res(nR, 7) = Res(nR, 7) + 1
      
        If Res(ik, 3) = "" Then
          Res(ik, 3) = sArr(i, 1)
        Else
          Res(ik, 3) = Res(ik, 3) & "," & sArr(i, 1)
        End If
      End If
    Next i
    k = k + 1
    Res(k, 6) = "Total placements"
    Res(k, 7) = Res(2, 7) + Res(nR, 7)
  End With
  [B1].Resize(k, 6).NumberFormat = "@"
  [B1].Resize(k, 7) = Res
End Sub

Function ImportTextToExcel(ByVal FilesToOpen As String) As Variant
  Dim fso As Object, TextSource As Object
  Dim sArr As Variant, Res As Variant, Sign(), Sign2(), Sign3(), iCol()
  Dim str As String, tmp As String
  Dim i As Long, k As Long, j As Long, n As Byte, sC As Byte ' luu y: khai bao bien j long, no byte, loi overflow
 
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set TextSource = fso.OpenTextFile(FilesToOpen, 1, False, -2)
  sArr = Split(TextSource.ReadAll, vbCrLf)
  ReDim Res(1 To UBound(sArr), 1 To 4)
 
  Sign = Array("Program Name =", "Line Name =")
  For i = LBound(sArr) To UBound(sArr)
    str = Application.Trim(sArr(i))
    For n = LBound(Sign) To UBound(Sign)
      If InStr(str, Sign(n)) Then
        j = InStr(str, Sign(n)) + Len(Sign(n)) + 1
        If Res(1, 1) = vbEmpty Then
          Res(1, 1) = Application.Trim(Split(Mid(str, j, 25), ".")(0))
        Else
          Res(1, 1) = Application.Trim(Mid(str, j, 20)) & "-" & Res(1, 1)
          j = i + 1: Exit For
        End If
      End If
    Next n
  Next i
 
  k = 1
  Sign = Array("Placement", "X", "Component Name", "Centering")
  ReDim iCol(LBound(Sign) To UBound(Sign))
  For i = j To UBound(sArr)
    str = sArr(i)
    If InStr(str, Sign(0)) Then
      For n = LBound(Sign) To UBound(Sign)
        iCol(n) = InStr(str, Sign(n))
      Next n
      j = i: Exit For
    End If
  Next i
 
  For i = j To UBound(sArr)
    str = sArr(i)
    If Len(Application.Trim(sArr(i))) < 2 Then j = i + 2: Exit For
    k = k + 1
    Res(k, 1) = Application.Trim(Mid(str, iCol(0), iCol(1) - iCol(0)))
    Res(k, 2) = Application.Trim(Mid(str, iCol(2), iCol(3) - iCol(2)))
  Next i
 
  Sign = Array("Feeder Position", "Component Name", "Component Name", "Comment", "Type", "Component pitch", "Component pitch", "Lane")
  ReDim iCol(LBound(Sign) To UBound(Sign))
  For i = j To UBound(sArr)
    str = sArr(i)
    If InStr(str, Sign(0)) Then
      For n = LBound(Sign) To UBound(Sign)
        iCol(n) = InStr(str, Sign(n))
      Next n
      j = i: Exit For
    End If
  Next i
 
  For i = j To UBound(sArr)
    str = sArr(i)
    If Len(Application.Trim(sArr(i))) < 2 Then Exit For
    k = k + 1
    For n = 1 To 4
      Res(k, n) = Application.Trim(Mid(str, iCol(n * 2 - 2), iCol(n * 2 - 1) - iCol(n * 2 - 2)))
    Next n
  Next i
 
  ImportTextToExcel = Res
  Set fso = Nothing: Set TextSource = Nothing
End Function
 
Chào các Bạn,
Không biết bài viết của mình có bị trôi không nữa, :)
Liệu rằng yêu cầu như trên có chúng ta có thể xử lý được không ạ, xin ý kiến của Các Bạn rành về VBA,
 
thehoang7 đã viết:
Chào các Bạn,
Không biết bài viết của mình có bị trôi không nữa, :)
Liệu rằng yêu cầu như trên có chúng ta có thể xử lý được không ạ, xin ý kiến của Các Bạn rành về VBA,
Nhấp chuột vào đây để mở rộng...
Rút gọn code
Mã: 
Sub Main()
  Dim sh As Worksheet, Res As Variant
  Dim FilesToOpen As String
  Dim i As Long, eRow As Long
 
  Set sh = Sheets("Sheet1")
  eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
  If eRow > 2 Then sh.Range("A3:H" & eRow).ClearContents
 
  With Application.FileDialog(msoFileDialogOpen)
    .AllowMultiSelect = True
    .Show
    For i = 1 To .SelectedItems.Count
      FilesToOpen = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i)
      Res = ImportTextToExcelStr(FilesToOpen)
      Res = XulyMang(Res)
      eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
      If eRow > 2 Then eRow = eRow + 1 Else eRow = 3
      sh.Range("A" & eRow).Resize(UBound(Res), 7).NumberFormat = "@"
      sh.Range("A" & eRow).Resize(UBound(Res), 8) = Res
    Next i
  End With
End Sub

Function XulyMang(ByVal sArr As Variant) As Variant
  Dim Res()
  Dim i As Long, mRow As Long, k As Long, ik As Long
  Dim proStr As String
 
  For i = 1 To UBound(sArr)
    If sArr(i, 1) = "Program" Then proStr = Mid(sArr(i, 4), 1, InStr(1, sArr(i, 4), ".") - 1)
    If sArr(i, 1) = "Feeder" Then mRow = i: Exit For
  Next i
 
  With CreateObject("scripting.dictionary")
    For i = mRow + 1 To UBound(sArr)
      If InStr(1, sArr(i, 1), "-") > 0 Then
        k = k + 1
        .Item(sArr(i, 3)) = k
      End If
    Next i
    ReDim Res(1 To k, 1 To 8)
    
    For i = 1 To mRow - 2
      ik = .Item(sArr(i, 7))
      If ik > 0 Then
        Res(ik, 4) = Res(ik, 4) & "," & sArr(i, 2)
        Res(ik, 8) = Res(ik, 8) + 1
      End If
    Next i
    
    k = 0
    For i = mRow + 1 To UBound(sArr)
      If InStr(1, sArr(i, 1), "-") > 0 Then
        k = k + 1
        Res(k, 1) = proStr:          Res(k, 2) = sArr(i, 1)
        Res(k, 3) = sArr(i, 3):      Res(k, 5) = sArr(i, 2)
        If Len(Res(k, 4)) > 0 Then Res(k, 4) = Mid(Res(k, 4), 2, Len(Res(k, 4)) - 1)
        If IsNumeric(Left(sArr(i, 7), 1)) Then
          Res(k, 6) = sArr(i, 6)
          Res(k, 7) = sArr(i, 7)
        Else
          Res(k, 6) = sArr(i, 6) & " " & sArr(i, 7)
          Res(k, 7) = sArr(i, 8)
        End If
      End If
    Next i
  End With
  XulyMang = Res
End Function

Function ImportTextToExcelStr(ByVal FilesToOpen As String) As Variant
  Dim fso As Object, TextSource As Object
  Dim sArr, S, Res()
  Dim i As Long, j As Integer, k As Long

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set TextSource = fso.OpenTextFile(FilesToOpen, 1, False, -2)
  sArr = Split(TextSource.ReadAll, vbCrLf)
  ReDim Res(1 To UBound(sArr) + 1, 1 To 1)
  For i = LBound(sArr) To UBound(sArr)
    S = Split(Application.Trim(sArr(i)), " ")
    If UBound(Res, 2) < UBound(S) + 1 Then
      ReDim Preserve Res(1 To UBound(sArr) + 1, 1 To UBound(S) + 1)
    End If
      k = k + 1
      For j = LBound(S) To UBound(S)
        Res(k, j + 1) = S(j)
      Next
  Next i
  ImportTextToExcelStr = Res
End Function
 
HieuCD đã viết:
Rút gọn code
Mã: 
Sub Main()
  Dim sh As Worksheet, Res As Variant
  Dim FilesToOpen As String
  Dim i As Long, eRow As Long

  Set sh = Sheets("Sheet1")
  eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
  If eRow > 2 Then sh.Range("A3:H" & eRow).ClearContents

  With Application.FileDialog(msoFileDialogOpen)
    .AllowMultiSelect = True
    .Show
    For i = 1 To .SelectedItems.Count
      FilesToOpen = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(i)
      Res = ImportTextToExcelStr(FilesToOpen)
      Res = XulyMang(Res)
      eRow = sh.Range("A" & Rows.Count).End(xlUp).Row
      If eRow > 2 Then eRow = eRow + 1 Else eRow = 3
      sh.Range("A" & eRow).Resize(UBound(Res), 7).NumberFormat = "@"
      sh.Range("A" & eRow).Resize(UBound(Res), 8) = Res
    Next i
  End With
End Sub

Function XulyMang(ByVal sArr As Variant) As Variant
  Dim Res()
  Dim i As Long, mRow As Long, k As Long, ik As Long
  Dim proStr As String

  For i = 1 To UBound(sArr)
    If sArr(i, 1) = "Program" Then proStr = Mid(sArr(i, 4), 1, InStr(1, sArr(i, 4), ".") - 1)
    If sArr(i, 1) = "Feeder" Then mRow = i: Exit For
  Next i

  With CreateObject("scripting.dictionary")
    For i = mRow + 1 To UBound(sArr)
      If InStr(1, sArr(i, 1), "-") > 0 Then
        k = k + 1
        .Item(sArr(i, 3)) = k
      End If
    Next i
    ReDim Res(1 To k, 1 To 8)
   
    For i = 1 To mRow - 2
      ik = .Item(sArr(i, 7))
      If ik > 0 Then
        Res(ik, 4) = Res(ik, 4) & "," & sArr(i, 2)
        Res(ik, 8) = Res(ik, 8) + 1
      End If
    Next i
   
    k = 0
    For i = mRow + 1 To UBound(sArr)
      If InStr(1, sArr(i, 1), "-") > 0 Then
        k = k + 1
        Res(k, 1) = proStr:          Res(k, 2) = sArr(i, 1)
        Res(k, 3) = sArr(i, 3):      Res(k, 5) = sArr(i, 2)
        If Len(Res(k, 4)) > 0 Then Res(k, 4) = Mid(Res(k, 4), 2, Len(Res(k, 4)) - 1)
        If IsNumeric(Left(sArr(i, 7), 1)) Then
          Res(k, 6) = sArr(i, 6)
          Res(k, 7) = sArr(i, 7)
        Else
          Res(k, 6) = sArr(i, 6) & " " & sArr(i, 7)
          Res(k, 7) = sArr(i, 8)
        End If
      End If
    Next i
  End With
  XulyMang = Res
End Function

Function ImportTextToExcelStr(ByVal FilesToOpen As String) As Variant
  Dim fso As Object, TextSource As Object
  Dim sArr, S, Res()
  Dim i As Long, j As Integer, k As Long

  Set fso = CreateObject("Scripting.FileSystemObject")
  Set TextSource = fso.OpenTextFile(FilesToOpen, 1, False, -2)
  sArr = Split(TextSource.ReadAll, vbCrLf)
  ReDim Res(1 To UBound(sArr) + 1, 1 To 1)
  For i = LBound(sArr) To UBound(sArr)
    S = Split(Application.Trim(sArr(i)), " ")
    If UBound(Res, 2) < UBound(S) + 1 Then
      ReDim Preserve Res(1 To UBound(sArr) + 1, 1 To UBound(S) + 1)
    End If
      k = k + 1
      For j = LBound(S) To UBound(S)
        Res(k, j + 1) = S(j)
      Next
  Next i
  ImportTextToExcelStr = Res
End Function
Nhấp chuột vào đây để mở rộng...
Cảm ơn bạn HieuCD,
Copy xem kết quả rồi mới biết, có lẽ chắc các cao thủ VBA đang bận nhiều việc,
Kết quả như mong muốn thì quá tuyệt rồi, làm sao lại có thể suy diễn logic và làm được như vậy nhỉ,
Cảm ơn bạn rất nhiều, Mình sẽ ngắm lại Code. hay thiệt.
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

Tuấn Bụng Bự
Không copy/move được sheet trong excel (2 người xem)
Trả lời
1
Đọc
24
Hoàng Tuấn 868
H
minhminh27
Reply lại email đã gửi
Trả lời
3
Đọc
357
Frankgrofe
F
Emyeuexcel
Tham chiếu nhều điều kiện với khoản thời gian
Trả lời
10
Đọc
161
lamvankhoat1
L
H
Tra cứu mã ngành theo hóa đơn
Trả lời
8
Đọc
173
Hoale85
H
Phonglinh0902
Hỗ trợ so sánh dữ liệu cột A và B điền kết quả cột C
Trả lời
2
Đọc
80
Phonglinh0902
Phonglinh0902
P
Bóc dự toán nhà dân
Trả lời
6
Đọc
100
thuytrangbp28
T
K
Xử lý (tắt) đường link địa chỉ ô trong excel khi đăng nhập tài khoản MS.
Trả lời
5
Đọc
168
Mr.hieudoanxd
Mr.hieudoanxd
Nguyễn Duy Tuân
Dùng AI trên Excel bằng hàm BS_AI, BS_AI_CHAT của Add-in A-Tools v10
    • Thích
    • Yêu thích
Trả lời
4
Đọc
363
Nguyễn Duy Tuân
Nguyễn Duy Tuân
N
  • Question Question
Xin giúp đỡ in phiếu thông tin hàng loạt có điều kiện (3 người xem)
2
Trả lời
28
Đọc
745
HUONGHCKT
H
H
Cách tính số giờ làm thêm vượt quá 300 giờ của người lao động
Trả lời
9
Đọc
150
Hoa minh27
H
L
lọc số "hợp đồng" trong chuỗi câu "diễn giải"
    • Cảm ơn
Trả lời
12
Đọc
277
Duy Tùng 9x
Duy Tùng 9x
Gà Công Nghệ
Làm sao biết email gửi đi thành công và thời gian người nhận email đã xem email của mình?
Trả lời
9
Đọc
4K
ptm0412
ptm0412
X
  • Question Question
Giúp điều chỉnh thông số công suất máy tự động theo tuần
Trả lời
0
Đọc
68
xsmarthome
X
O
XIN ANH CHỊ GIÚP ĐỠ HƯỚNG DẪN CHUYỂN VĂN BẢN THÀNH GIỌNG NÓI TRONG EXCEL Ạ.
2
Trả lời
25
Đọc
595
ongke0711
ongke0711
C
Giúp mình cập nhật dữ liệu từ google sheet về excel 2010 bằng VBA
Trả lời
3
Đọc
188
Nguyễn Duy Tuân
Nguyễn Duy Tuân
hoamattroicoi
TỔNG HỢP TỜ KHAI THUẾ THEO THÔNG TƯ 80/2021 TỪ *.XML SANG EXCEL
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
8
Đọc
4K
khoind.mcr
K
L
[Cần giúp] Cách liên kết các file Google sheet với nhau
Trả lời
13
Đọc
11K
SonBDND
S
Anhhe
Em xin nhờ các cao nhân chỉ giáo em cách tính giờ làm việc của nhân viên với ạ Plz
Trả lời
11
Đọc
380
thanthanhan
T
Đ
gỡ rỗi công thức
    • Buồn
Trả lời
4
Đọc
107
Đình Bảo đl
Đ
test1986
  • Question Question
Thắc mắc về vba và unicode
Trả lời
4
Đọc
170
test1986
test1986
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
[GPE] HỘI THẢO POWER QUERY – CÔNG CỤ QUẢN LÝ DỮ LIỆU HCM
Back
Top Bottom