Lọc lấy dữ liệu cần trong tập tin .txt vào tập tin .xlsx (1 người xem)

th7 · 11/7/21

Xin chào các Bạn trong diễn đàn.
Hiện tại, mình muốn lấy dữ liệu để làm việc phân tích xem máy gắn linh kiện trên dây chuyền bị những lỗi gì. Trên máy cắm linh kiện, máy có hỗ trợ xuất dữ liệu theo kiểu .txt.
Trên dây chuyền, mình có 2 dòng máy, kiểu xuất dữ liệu ra file .txt cũng hơi khác nhau nên mình có đính kèm hai file dữ liệu, 1 là của máy KE, 1 là của máy RS
Mình có để dữ liệu muốn lấy ở trong file excel.
Nhờ các Bạn xem qua, hỗ trợ mình được không?
Một ngày, chạy rất nhiều sản phẩm, giả sử trên máy KE hoặc RS em có 5 tới 10 file .txt, mình có thể thao để chung các file đó vào 1 folder và VBA code có thể hỗ trợ một lần chạy và cập nhật dữ liệu được không,
Nhờ các Bạn xem qua, và góp ý hỗ trợ.
Mình cảm ơn

Hoàng Nhật Phương · 12/7/21

thehoang7 đã viết:
Xin chào các Bạn trong diễn đàn.
Hiện tại, mình muốn lấy dữ liệu để làm việc phân tích xem máy gắn linh kiện trên dây chuyền bị những lỗi gì. Trên máy cắm linh kiện, máy có hỗ trợ xuất dữ liệu theo kiểu .txt.
Trên dây chuyền, mình có 2 dòng máy, kiểu xuất dữ liệu ra file .txt cũng hơi khác nhau nên mình có đính kèm hai file dữ liệu, 1 là của máy KE, 1 là của máy RS
Mình có để dữ liệu muốn lấy ở trong file excel.
Nhờ các Bạn xem qua, hỗ trợ mình được không?
Một ngày, chạy rất nhiều sản phẩm, giả sử trên máy KE hoặc RS em có 5 tới 10 file .txt, mình có thể thao để chung các file đó vào 1 folder và VBA code có thể hỗ trợ một lần chạy và cập nhật dữ liệu được không,
Nhờ các Bạn xem qua, và góp ý hỗ trợ.
Mình cảm ơn

OT không đủ khả năng để viết hoàn chỉnh Sub ghi_dulieu , bạn nhờ mọi người trên diễn đàn giúp tiếp nhé:

Mã:

Option Explicit
    
Public Const sRS As String = "RS"
Public Const sKE As String = "KE"

Public Const c_ProductionInformations As String = "Production Informations"
Public Const c_ProgramName As String = "Program name = "

Public Sub Open_Files()
    
    Dim fs As New Scripting.FileSystemObject
    Dim oFolder As Object, oFile As Object, soFile As Object
    Dim file_name As String, sFolder As String, sFile As String
    Dim book As Workbook, shOut As Worksheet
    Dim book_open As Workbook, sheet_open As Worksheet
    Dim r As Long, c As Long, str As String, data()
    
    Const duoifile As String = ".txt"
    Set book = ThisWorkbook
    sFolder = book.Path
    Set oFolder = fs.GetFolder(sFolder)
    Set soFile = oFolder.Files
    
    c = soFile.Count
    If c = 0 Then
        Exit Sub
    End If

    Dim Tmr As Double
    Tmr = Timer()

    On Error GoTo Err_
    
    get_speed True
    
    For Each shOut In book.Worksheets
        If shOut.Name = sRS Or shOut.Name = sKE Then
            If shOut.AutoFilterMode Then shOut.AutoFilterMode = False
            r = iLastRowInOneColumn(shOut) - 1: c = iLastColumnInOneRow(shOut)
            If r > 1 Then shOut.Range("A2").Resize(r, c).ClearContents
        End If
    Next shOut
    
    For Each oFile In oFolder.Files
        If oFile.Name Like "*" & duoifile Then
            file_name = oFile.Name
            If file_name Like "*" & sKE & "*" Then
                Set shOut = book.Worksheets(sKE)
                str = sKE
            ElseIf file_name Like "*" & sRS & "*" Then
                Set shOut = book.Worksheets(sRS)
                str = sRS
            End If
            Set book_open = OpenBook(sFolder, file_name, True)
            If Not book_open Is Nothing Then
                Set sheet_open = book_open.Worksheets(1)
                r = iLastRowInOneColumn(sheet_open)
                c = iLastColumnInOneRow(sheet_open)
                If r > 1 Then
                    data = sheet_open.Range("A1").Resize(r, c).Value
                    ghi_dulieu data, shOut, str
                    If Len(sFile) = 0 Then
                        sFile = file_name
                    Else
                        sFile = sFile & vbNewLine & file_name
                    End If
                End If
                CloseBookIfOpenByMe book_open, False
            End If
        End If
    Next oFile
    
    get_speed False
    Set fs = Nothing
    
    If Len(sFile) > 0 Then
        sFile = "Cac tap tin da mo va lay du lieu: " & vbNewLine & sFile
    Else
        sFile = "Khong co tap tin nao duoc mo!"
    End If
    MsgBox "OK , Xong !" & vbNewLine & "Thoi gian thuc hien la: " & Round(Timer() - Tmr, 2) & " giay" & _
            vbNewLine & vbNewLine & sFile, vbInformation + vbOKOnly, "Bao cao"
    
    Exit Sub
    
Err_:

If Err.Number <> 0 Then
    get_speed False
    MsgBox "Xay ra loi : " & Err.Description, vbCritical + vbOKOnly, _
    "Err Number:" & Err.Number
End If

End Sub

Public Sub ghi_dulieu(ByRef data, ByVal shOut As Worksheet, ByVal str)

    Dim lr As Long, r As Long, c As Long, batdau As Boolean
    Dim res(), i As Long, j As Long, k As Long, s As String
    Dim idate As Date, s_ProgramName As String
    
    r = UBound(data, 1): c = 20
    lr = iLastRowInOneColumn(shOut) + 1
    ReDim res(1 To r, 1 To c)
    k = 1
    For i = 1 To r
    
        If data(i, 1) = c_ProductionInformations Then
            s = data(i, 3)
            idate = Mid(s, 15, 19)
        End If
        
        
        If data(i, 1) Like c_ProgramName & "*" Then
            s = data(i, 1)
            s = Mid(s, Len(c_ProgramName) + 1, Len(s) - Len(c_ProgramName))
            s_ProgramName = Split(s, ".")(0)
        End If
        
        s = data(i, 1)
        If InStr(3, s, "*") Then batdau = True Else batdau = False

        If batdau Then
            s = data(i, 1)
            If str = sKE Then
                res(k, 1) = idate
                res(k, 2) = s_ProgramName
                res(k, 3) = Split(s, "*")(0)
                res(k, 4) = Split(Split(s, "*")(1), "   ")(0)
                res(k, 5) = Split(Split(s, "*")(1), "   ")(1)
                res(k, 6) = Split(Split(s, "*")(1), "   ")(2)
                '....
                k = k + 1
            ElseIf str = sRS Then
                res(k, 1) = idate
                res(k, 2) = s_ProgramName
                res(k, 3) = Split(s, "*")(0)
                res(k, 4) = Split(Split(s, "*")(1), "   ")(0)
                '....
                k = k + 1
            End If
        End If
        
    Next i
    
    If k > 0 Then shOut.Range("A" & lr).Resize(k, c) = res

End Sub

ongke0711 · 12/7/21

thehoang7 đã viết:
Trên dây chuyền, mình có 2 dòng máy, kiểu xuất dữ liệu ra file .txt cũng hơi khác nhau nên mình có đính kèm hai file dữ liệu, 1 là của máy KE, 1 là của máy RS
Mình có để dữ liệu muốn lấy ở trong file excel.
Nhờ các Bạn xem qua, hỗ trợ mình được không?
Một ngày, chạy rất nhiều sản phẩm, giả sử trên máy KE hoặc RS em có 5 tới 10 file .txt, mình có thể thao để chung các file đó vào 1 folder và VBA code có thể hỗ trợ một lần chạy và cập nhật dữ liệu được không,

Tôi dùng FreeFile để đọc từng dòng dữ liệu rồi xử lý file text của bạn.
File này chỉ chạy đúng nếu định dạng cột dòng bên trong các file text giống y chang như file bạn gửi. Theo tôi thấy đây thuộc dạng file báo cáo rồi chứ không phải dữ liệu thô nên xử lý cũng rườm rà, thủ công. Chỉ làm sơ sơ được như vậy thôi.

Bạn xem file đính kèm.

(* Cập nhật lại file cho gọn gàng chút)

th7 · 12/7/21

Hoàng Nhật Phương đã viết:

OT không đủ khả năng để viết hoàn chỉnh Sub ghi_dulieu , bạn nhờ mọi người trên diễn đàn giúp tiếp nhé:

Mã:

Option Explicit
   
Public Const sRS As String = "RS"
Public Const sKE As String = "KE"

Public Const c_ProductionInformations As String = "Production Informations"
Public Const c_ProgramName As String = "Program name = "

Public Sub Open_Files()
   
    Dim fs As New Scripting.FileSystemObject
    Dim oFolder As Object, oFile As Object, soFile As Object
    Dim file_name As String, sFolder As String, sFile As String
    Dim book As Workbook, shOut As Worksheet
    Dim book_open As Workbook, sheet_open As Worksheet
    Dim r As Long, c As Long, str As String, data()
   
    Const duoifile As String = ".txt"
    Set book = ThisWorkbook
    sFolder = book.Path
    Set oFolder = fs.GetFolder(sFolder)
    Set soFile = oFolder.Files
   
    c = soFile.Count
    If c = 0 Then
        Exit Sub
    End If

    Dim Tmr As Double
    Tmr = Timer()

    On Error GoTo Err_
   
    get_speed True
   
    For Each shOut In book.Worksheets
        If shOut.Name = sRS Or shOut.Name = sKE Then
            If shOut.AutoFilterMode Then shOut.AutoFilterMode = False
            r = iLastRowInOneColumn(shOut) - 1: c = iLastColumnInOneRow(shOut)
            If r > 1 Then shOut.Range("A2").Resize(r, c).ClearContents
        End If
    Next shOut
   
    For Each oFile In oFolder.Files
        If oFile.Name Like "*" & duoifile Then
            file_name = oFile.Name
            If file_name Like "*" & sKE & "*" Then
                Set shOut = book.Worksheets(sKE)
                str = sKE
            ElseIf file_name Like "*" & sRS & "*" Then
                Set shOut = book.Worksheets(sRS)
                str = sRS
            End If
            Set book_open = OpenBook(sFolder, file_name, True)
            If Not book_open Is Nothing Then
                Set sheet_open = book_open.Worksheets(1)
                r = iLastRowInOneColumn(sheet_open)
                c = iLastColumnInOneRow(sheet_open)
                If r > 1 Then
                    data = sheet_open.Range("A1").Resize(r, c).Value
                    ghi_dulieu data, shOut, str
                    If Len(sFile) = 0 Then
                        sFile = file_name
                    Else
                        sFile = sFile & vbNewLine & file_name
                    End If
                End If
                CloseBookIfOpenByMe book_open, False
            End If
        End If
    Next oFile
   
    get_speed False
    Set fs = Nothing
   
    If Len(sFile) > 0 Then
        sFile = "Cac tap tin da mo va lay du lieu: " & vbNewLine & sFile
    Else
        sFile = "Khong co tap tin nao duoc mo!"
    End If
    MsgBox "OK , Xong !" & vbNewLine & "Thoi gian thuc hien la: " & Round(Timer() - Tmr, 2) & " giay" & _
            vbNewLine & vbNewLine & sFile, vbInformation + vbOKOnly, "Bao cao"
   
    Exit Sub
   
Err_:

If Err.Number <> 0 Then
    get_speed False
    MsgBox "Xay ra loi : " & Err.Description, vbCritical + vbOKOnly, _
    "Err Number:" & Err.Number
End If

End Sub

Public Sub ghi_dulieu(ByRef data, ByVal shOut As Worksheet, ByVal str)

    Dim lr As Long, r As Long, c As Long, batdau As Boolean
    Dim res(), i As Long, j As Long, k As Long, s As String
    Dim idate As Date, s_ProgramName As String
   
    r = UBound(data, 1): c = 20
    lr = iLastRowInOneColumn(shOut) + 1
    ReDim res(1 To r, 1 To c)
    k = 1
    For i = 1 To r
   
        If data(i, 1) = c_ProductionInformations Then
            s = data(i, 3)
            idate = Mid(s, 15, 19)
        End If
       
       
        If data(i, 1) Like c_ProgramName & "*" Then
            s = data(i, 1)
            s = Mid(s, Len(c_ProgramName) + 1, Len(s) - Len(c_ProgramName))
            s_ProgramName = Split(s, ".")(0)
        End If
       
        s = data(i, 1)
        If InStr(3, s, "*") Then batdau = True Else batdau = False

        If batdau Then
            s = data(i, 1)
            If str = sKE Then
                res(k, 1) = idate
                res(k, 2) = s_ProgramName
                res(k, 3) = Split(s, "*")(0)
                res(k, 4) = Split(Split(s, "*")(1), "   ")(0)
                res(k, 5) = Split(Split(s, "*")(1), "   ")(1)
                res(k, 6) = Split(Split(s, "*")(1), "   ")(2)
                '....
                k = k + 1
            ElseIf str = sRS Then
                res(k, 1) = idate
                res(k, 2) = s_ProgramName
                res(k, 3) = Split(s, "*")(0)
                res(k, 4) = Split(Split(s, "*")(1), "   ")(0)
                '....
                k = k + 1
            End If
        End If
       
    Next i
   
    If k > 0 Then shOut.Range("A" & lr).Resize(k, c) = res

End Sub

Cảm ơn Bạn

Hoàng Nhật Phương nha,

Mình có đính kèm thêm dữ liêu, 5 tập tin .txt cho mỗi loại máy, KE và RS.
Bạn tham khảo nha,
Định dạng mà dữ liệu hoặc là của KE hoặc là RS thì đều giống nhau.

ongke0711 · 12/7/21

thehoang7 đã viết:
Định dạng mà dữ liệu hoặc là của KE hoặc là RS thì đều giống nhau.

Tải lại file. Lúc nãy đính kèm nhầm file.

Hoàng Nhật Phương · 12/7/21

ongke0711 đã viết:
Tải lại file. Lúc nãy đính kèm nhầm file.

Lợi hại quá anh ạ :yahoo:

th7 · 13/7/21

ongke0711 đã viết:
Tải lại file. Lúc nãy đính kèm nhầm file.

Chào Bạn

ongke0711

Cảm ơn bài viết chia sẻ của bạn nha,
Gần như là hoàn chỉnh rồi,
Mình có thử áp dụng và có hai ý muốn hỏi Bạn, Bạn xem có ý kiến gì không nha,
- Đối với dữ liệu cho máy RS xuất ra thì thông tin tại cột "Compo. name" trong .txt nó cho phép lưu đến khoảng 20 kí tự, nên dữ liệu cột này khi mình xuất ra, nó đầy đủ thông tin,
- Đối với dữ liệu khi máy KE xuất thì tại cột "Compo. name" này, 13 kí tự, nhưng khi mình kéo xuống thì kế dưới dòng "< Ratio of Pick-up..." thông tin nó lại đủ.
-> Bạn cho mình hỏi, bạn có thể lấy đủ thông tin xuất ra cho "Compo. name" trên dữ liệu KE không,
+ Mình thấy các file .txt phải lưu dưới dạng tên với kí tự đầu là KE hoặc RS thì Code mới chạy đúng, Bạn cho mình hỏi, mình có thể đặt các file của RS và KE vào chung một folder và lưu tên mặc định là KE + Tên sản phẩm hoặc RS + Tên sản phẩm rồi chọn tất cả để chạy cùng một lúc được không, và dữ liệu của KE hoặc RS thì sẽ nối tiếp trong file Excel. vấn đề này, mình có thể làm được không bạn,
Nhờ Bạn cho ý kiến,
Cảm ơn Bạn đã hỗ trợ mình Code ở trên.

truongvu317 · 13/7/21

Hoàng Nhật Phương đã viết:

OT không đủ khả năng để viết hoàn chỉnh Sub ghi_dulieu , bạn nhờ mọi người trên diễn đàn giúp tiếp nhé:

Mã:

Option Explicit
   
Public Const sRS As String = "RS"
Public Const sKE As String = "KE"

Public Const c_ProductionInformations As String = "Production Informations"
Public Const c_ProgramName As String = "Program name = "

Public Sub Open_Files()
   
    Dim fs As New Scripting.FileSystemObject
    Dim oFolder As Object, oFile As Object, soFile As Object
    Dim file_name As String, sFolder As String, sFile As String
    Dim book As Workbook, shOut As Worksheet
    Dim book_open As Workbook, sheet_open As Worksheet
    Dim r As Long, c As Long, str As String, data()
   
    Const duoifile As String = ".txt"
    Set book = ThisWorkbook
    sFolder = book.Path
    Set oFolder = fs.GetFolder(sFolder)
    Set soFile = oFolder.Files
   
    c = soFile.Count
    If c = 0 Then
        Exit Sub
    End If

    Dim Tmr As Double
    Tmr = Timer()

    On Error GoTo Err_
   
    get_speed True
   
    For Each shOut In book.Worksheets
        If shOut.Name = sRS Or shOut.Name = sKE Then
            If shOut.AutoFilterMode Then shOut.AutoFilterMode = False
            r = iLastRowInOneColumn(shOut) - 1: c = iLastColumnInOneRow(shOut)
            If r > 1 Then shOut.Range("A2").Resize(r, c).ClearContents
        End If
    Next shOut
   
    For Each oFile In oFolder.Files
        If oFile.Name Like "*" & duoifile Then
            file_name = oFile.Name
            If file_name Like "*" & sKE & "*" Then
                Set shOut = book.Worksheets(sKE)
                str = sKE
            ElseIf file_name Like "*" & sRS & "*" Then
                Set shOut = book.Worksheets(sRS)
                str = sRS
            End If
            Set book_open = OpenBook(sFolder, file_name, True)
            If Not book_open Is Nothing Then
                Set sheet_open = book_open.Worksheets(1)
                r = iLastRowInOneColumn(sheet_open)
                c = iLastColumnInOneRow(sheet_open)
                If r > 1 Then
                    data = sheet_open.Range("A1").Resize(r, c).Value
                    ghi_dulieu data, shOut, str
                    If Len(sFile) = 0 Then
                        sFile = file_name
                    Else
                        sFile = sFile & vbNewLine & file_name
                    End If
                End If
                CloseBookIfOpenByMe book_open, False
            End If
        End If
    Next oFile
   
    get_speed False
    Set fs = Nothing
   
    If Len(sFile) > 0 Then
        sFile = "Cac tap tin da mo va lay du lieu: " & vbNewLine & sFile
    Else
        sFile = "Khong co tap tin nao duoc mo!"
    End If
    MsgBox "OK , Xong !" & vbNewLine & "Thoi gian thuc hien la: " & Round(Timer() - Tmr, 2) & " giay" & _
            vbNewLine & vbNewLine & sFile, vbInformation + vbOKOnly, "Bao cao"
   
    Exit Sub
   
Err_:

If Err.Number <> 0 Then
    get_speed False
    MsgBox "Xay ra loi : " & Err.Description, vbCritical + vbOKOnly, _
    "Err Number:" & Err.Number
End If

End Sub

Public Sub ghi_dulieu(ByRef data, ByVal shOut As Worksheet, ByVal str)

    Dim lr As Long, r As Long, c As Long, batdau As Boolean
    Dim res(), i As Long, j As Long, k As Long, s As String
    Dim idate As Date, s_ProgramName As String
   
    r = UBound(data, 1): c = 20
    lr = iLastRowInOneColumn(shOut) + 1
    ReDim res(1 To r, 1 To c)
    k = 1
    For i = 1 To r
   
        If data(i, 1) = c_ProductionInformations Then
            s = data(i, 3)
            idate = Mid(s, 15, 19)
        End If
       
       
        If data(i, 1) Like c_ProgramName & "*" Then
            s = data(i, 1)
            s = Mid(s, Len(c_ProgramName) + 1, Len(s) - Len(c_ProgramName))
            s_ProgramName = Split(s, ".")(0)
        End If
       
        s = data(i, 1)
        If InStr(3, s, "*") Then batdau = True Else batdau = False

        If batdau Then
            s = data(i, 1)
            If str = sKE Then
                res(k, 1) = idate
                res(k, 2) = s_ProgramName
                res(k, 3) = Split(s, "*")(0)
                res(k, 4) = Split(Split(s, "*")(1), "   ")(0)
                res(k, 5) = Split(Split(s, "*")(1), "   ")(1)
                res(k, 6) = Split(Split(s, "*")(1), "   ")(2)
                '....
                k = k + 1
            ElseIf str = sRS Then
                res(k, 1) = idate
                res(k, 2) = s_ProgramName
                res(k, 3) = Split(s, "*")(0)
                res(k, 4) = Split(Split(s, "*")(1), "   ")(0)
                '....
                k = k + 1
            End If
        End If
       
    Next i
   
    If k > 0 Then shOut.Range("A" & lr).Resize(k, c) = res

End Sub

Code công phu quá, có nhiều ý tưởng các bạn khác có thể muốn thử á dụng

ongke0711 · 13/7/21

thehoang7 đã viết:
+ Mình thấy các file .txt phải lưu dưới dạng tên với kí tự đầu là KE hoặc RS thì Code mới chạy đúng, Bạn cho mình hỏi, mình có thể đặt các file của RS và KE vào chung một folder và lưu tên mặc định là KE + Tên sản phẩm hoặc RS + Tên sản phẩm rồi chọn tất cả để chạy cùng một lúc được không, và dữ liệu của KE hoặc RS thì sẽ nối tiếp trong file Excel. vấn đề này, mình có thể làm được không bạn,

Bạn tải lại file tôi đã cập nhật ở trên. Code tự nhận dạng nó là file RS hay KE để đưa dữ liệu vào đúng Sheet của nó, không cần thay đổi tên hay folder gì cả.
Còn vụ cập nhật Compo.Name thì để xem lại, trả lời sau nhé.

th7 · 13/7/21

ongke0711 đã viết:
Tôi dùng FreeFile để đọc từng dòng dữ liệu rồi xử lý file text của bạn.
File này chỉ chạy đúng nếu định dạng cột dòng bên trong các file text giống y chang như file bạn gửi. Theo tôi thấy đây thuộc dạng file báo cáo rồi chứ không phải dữ liệu thô nên xử lý cũng rườm rà, thủ công. Chỉ làm sơ sơ được như vậy thôi.

Bạn xem file đính kèm.

(* Cập nhật lại file cho gọn gàng chút)

Cũng khuy rồi, Bạn còn dành thời gian xem và chỉnh sửa Code,
Cảm ơn Bạn rất nhiều, Ongke0711.

th7 · 14/7/21

ongke0711 đã viết:
Bạn tải lại file tôi đã cập nhật ở trên. Code tự nhận dạng nó là file RS hay KE để đưa dữ liệu vào đúng Sheet của nó, không cần thay đổi tên hay folder gì cả.
Còn vụ cập nhật Compo.Name thì để xem lại, trả lời sau nhé.

Chào bạn Ongke0711,
Nếu có thời gian, nhờ Bạn kiểm tra mình việc cập nhật đủ thông tin cho cột Compo.Name cho dòng máy KE với nha.

HieuCD · 15/7/21

thehoang7 đã viết:
Xin chào các Bạn trong diễn đàn.
Hiện tại, mình muốn lấy dữ liệu để làm việc phân tích xem máy gắn linh kiện trên dây chuyền bị những lỗi gì. Trên máy cắm linh kiện, máy có hỗ trợ xuất dữ liệu theo kiểu .txt.
Trên dây chuyền, mình có 2 dòng máy, kiểu xuất dữ liệu ra file .txt cũng hơi khác nhau nên mình có đính kèm hai file dữ liệu, 1 là của máy KE, 1 là của máy RS
Mình có để dữ liệu muốn lấy ở trong file excel.
Nhờ các Bạn xem qua, hỗ trợ mình được không?
Một ngày, chạy rất nhiều sản phẩm, giả sử trên máy KE hoặc RS em có 5 tới 10 file .txt, mình có thể thao để chung các file đó vào 1 folder và VBA code có thể hỗ trợ một lần chạy và cập nhật dữ liệu được không,
Nhờ các Bạn xem qua, và góp ý hỗ trợ.
Mình cảm ơn

Dữ liệu khá rối, code cũng rối
Kiểm tra lại

Mã:

Option Explicit

Sub DeleteRes()
  Dim shArr, i&, eR&
  shArr = Array("KE", "RS")
  For i = 0 To 1
    eR = Sheets(shArr(i)).Range("A" & Rows.Count).End(xlUp).Row
    If eR > 1 Then Sheets(shArr(i)).Range("A2:X" & eR).ClearContents
  Next i
End Sub

Sub Main()
  Dim fso As Object, Dic As Object, FilesToOpen$, n&
 
  Set Dic = CreateObject("scripting.dictionary")
  Set fso = CreateObject("Scripting.FileSystemObject")
  'Call DeleteRes
  With Application.FileDialog(msoFileDialogFilePicker)
    .InitialFileName = ThisWorkbook.Path
    .Filters.Add "Text files", "*.txt; *.rtf", 1
    .Title = "Select text file."
    .AllowMultiSelect = True
    If Not .Show = -1 Then Exit Sub
    For n = 1 To .SelectedItems.Count
      Call CreateRes(fso, Dic, .SelectedItems(n))
      Dic.RemoveAll
    Next n
  End With
End Sub

Private Sub CreateRes(fso, Dic, ByVal FilesToOpen As String)
  Dim TextSource As Object, S, tArr, Res()
  Dim shName$, sply$, proName$, iDate As Date
  Dim i&, k&, ik&, n&, d&, c&, jCol&
 
  Set TextSource = fso.OpenTextFile(FilesToOpen, 1, False, -2) ' default
  tArr = Split(TextSource.ReadAll, vbCrLf) ' default
  ReDim sarr(1 To UBound(tArr), 1 To 2)
  iDate = DateValue(Mid(tArr(0), InStr(1, tArr(0), "/") - 4, 10)) 'Date
  For i = LBound(tArr) To UBound(tArr)
    If InStr(1, tArr(i), "Program name", vbTextCompare) Then 'Program name
      proName = Replace(Split(Mid(tArr(i), InStr(1, tArr(i), "=") + 1, 30), ".")(0), " ", "")
      Exit For
    End If
  Next i
  d = 0
  If InStr(1, tArr(0), "JUKI KE") > 0 Then
    shName = "KE"
    ReDim Res(1 To UBound(tArr), 1 To 20)
    For i = LBound(tArr) To UBound(tArr)
      If InStr(1, tArr(i), "*") Then
        sply = Replace(Mid(tArr(i), 9, 6), " ", "")
        If Dic.exists(sply) = False Then
          k = k + 1:            jCol = 4
          Dic.Add sply, k
          Res(k, 1) = iDate:   Res(k, 2) = proName:   Res(k, 3) = sply
          S = Split(Application.Trim(Mid(tArr(i), 34, 100)), " ")
          For n = 0 To UBound(S)
            jCol = jCol + 1
            Res(k, jCol) = S(n)
          Next n
        Else
          ik = Dic.Item(sply)
          Res(ik, 4) = Application.Trim(Mid(tArr(i), 18, 26))
          Res(ik, jCol + 1) = Application.Trim(Mid(tArr(i), 63, 8))
        End If
      End If
    Next i
  ElseIf InStr(1, tArr(0), "JUKI RS") > 0 Then
    shName = "RS"
    ReDim Res(1 To UBound(tArr), 1 To 24)
    For i = LBound(tArr) To UBound(tArr)
       If i = 142 Then
        ik = 1
      End If
      If InStr(1, Replace(tArr(i), " ", ""), "SplyCompo.namePicked", vbTextCompare) Then
        d = 4
      ElseIf InStr(1, Replace(tArr(i), " ", ""), "SplyCompo.nameRcg", vbTextCompare) Then
        d = 13
      ElseIf InStr(1, Replace(tArr(i), " ", ""), "SplyLComponentname", vbTextCompare) Then
        d = 22
      End If
      If d > 0 Then
        c = InStr(1, Replace(tArr(i), "--", "  "), "-")
        If c > 0 And c < 15 Then
          sply = Replace(Mid(tArr(i), 9, 7), " ", "")
          If Dic.exists(sply) = False Then
            k = k + 1
            Dic.Add sply, k
            Res(k, 1) = iDate:   Res(k, 2) = proName:   Res(k, 3) = sply
            Res(k, 4) = Application.Trim(Mid(tArr(i), 18, 18))
          End If
          ik = Dic.Item(sply)
          S = Split(Application.Trim(Mid(tArr(i), 37, 100)), " ")
          jCol = d
          If d < 22 Then
            For n = 0 To UBound(S)
              jCol = jCol + 1
              Res(ik, jCol) = S(n)
            Next n
          Else
            Res(ik, 23) = Application.Trim(Mid(tArr(i), 86, 8))
            Res(ik, 24) = Application.Trim(Mid(tArr(i), 98, 8))
          End If
        End If
      End If
    Next i
  End If
  With Sheets(shName)
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If k Then .Range("A" & i + 1).Resize(k, UBound(Res, 2)) = Res
  End With
  Set TextSource = Nothing
End Sub

th7 · 15/7/21

HieuCD đã viết:

Dữ liệu khá rối, code cũng rối
Kiểm tra lại

Mã:

Option Explicit

Sub DeleteRes()
  Dim shArr, i&, eR&
  shArr = Array("KE", "RS")
  For i = 0 To 1
    eR = Sheets(shArr(i)).Range("A" & Rows.Count).End(xlUp).Row
    If eR > 1 Then Sheets(shArr(i)).Range("A2:X" & eR).ClearContents
  Next i
End Sub

Sub Main()
  Dim fso As Object, Dic As Object, FilesToOpen$, n&
 
  Set Dic = CreateObject("scripting.dictionary")
  Set fso = CreateObject("Scripting.FileSystemObject")
  'Call DeleteRes
  With Application.FileDialog(msoFileDialogFilePicker)
    .InitialFileName = ThisWorkbook.Path
    .Filters.Add "Text files", "*.txt; *.rtf", 1
    .Title = "Select text file."
    .AllowMultiSelect = True
    If Not .Show = -1 Then Exit Sub
    For n = 1 To .SelectedItems.Count
      Call CreateRes(fso, Dic, .SelectedItems(n))
      Dic.RemoveAll
    Next n
  End With
End Sub

Private Sub CreateRes(fso, Dic, ByVal FilesToOpen As String)
  Dim TextSource As Object, S, tArr, Res()
  Dim shName$, sply$, proName$, iDate As Date
  Dim i&, k&, ik&, n&, d&, c&, jCol&
 
  Set TextSource = fso.OpenTextFile(FilesToOpen, 1, False, -2) ' default
  tArr = Split(TextSource.ReadAll, vbCrLf) ' default
  ReDim sarr(1 To UBound(tArr), 1 To 2)
  iDate = DateValue(Mid(tArr(0), InStr(1, tArr(0), "/") - 4, 10)) 'Date
  For i = LBound(tArr) To UBound(tArr)
    If InStr(1, tArr(i), "Program name", vbTextCompare) Then 'Program name
      proName = Replace(Split(Mid(tArr(i), InStr(1, tArr(i), "=") + 1, 30), ".")(0), " ", "")
      Exit For
    End If
  Next i
  d = 0
  If InStr(1, tArr(0), "JUKI KE") > 0 Then
    shName = "KE"
    ReDim Res(1 To UBound(tArr), 1 To 20)
    For i = LBound(tArr) To UBound(tArr)
      If InStr(1, tArr(i), "*") Then
        sply = Replace(Mid(tArr(i), 9, 6), " ", "")
        If Dic.exists(sply) = False Then
          k = k + 1:            jCol = 4
          Dic.Add sply, k
          Res(k, 1) = iDate:   Res(k, 2) = proName:   Res(k, 3) = sply
          S = Split(Application.Trim(Mid(tArr(i), 34, 100)), " ")
          For n = 0 To UBound(S)
            jCol = jCol + 1
            Res(k, jCol) = S(n)
          Next n
        Else
          ik = Dic.Item(sply)
          Res(ik, 4) = Application.Trim(Mid(tArr(i), 18, 26))
          Res(ik, jCol + 1) = Application.Trim(Mid(tArr(i), 63, 8))
        End If
      End If
    Next i
  ElseIf InStr(1, tArr(0), "JUKI RS") > 0 Then
    shName = "RS"
    ReDim Res(1 To UBound(tArr), 1 To 24)
    For i = LBound(tArr) To UBound(tArr)
       If i = 142 Then
        ik = 1
      End If
      If InStr(1, Replace(tArr(i), " ", ""), "SplyCompo.namePicked", vbTextCompare) Then
        d = 4
      ElseIf InStr(1, Replace(tArr(i), " ", ""), "SplyCompo.nameRcg", vbTextCompare) Then
        d = 13
      ElseIf InStr(1, Replace(tArr(i), " ", ""), "SplyLComponentname", vbTextCompare) Then
        d = 22
      End If
      If d > 0 Then
        c = InStr(1, Replace(tArr(i), "--", "  "), "-")
        If c > 0 And c < 15 Then
          sply = Replace(Mid(tArr(i), 9, 7), " ", "")
          If Dic.exists(sply) = False Then
            k = k + 1
            Dic.Add sply, k
            Res(k, 1) = iDate:   Res(k, 2) = proName:   Res(k, 3) = sply
            Res(k, 4) = Application.Trim(Mid(tArr(i), 18, 18))
          End If
          ik = Dic.Item(sply)
          S = Split(Application.Trim(Mid(tArr(i), 37, 100)), " ")
          jCol = d
          If d < 22 Then
            For n = 0 To UBound(S)
              jCol = jCol + 1
              Res(ik, jCol) = S(n)
            Next n
          Else
            Res(ik, 23) = Application.Trim(Mid(tArr(i), 86, 8))
            Res(ik, 24) = Application.Trim(Mid(tArr(i), 98, 8))
          End If
        End If
      End If
    Next i
  End If
  With Sheets(shName)
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If k Then .Range("A" & i + 1).Resize(k, UBound(Res, 2)) = Res
  End With
  Set TextSource = Nothing
End Sub

Em chào anh HieuCD,
Em có để Code vào, nhưng khi chạy thì hiện lỗi
(Run-time error '9':
Subscript out ò range)
Nhờ Anh kiểm tra dùm em được không ạ
Cảm ơn Anh.

HieuCD · 15/7/21

thehoang7 đã viết:
Em chào anh HieuCD,
Em có để Code vào, nhưng khi chạy thì hiện lỗi
(Run-time error '9':
Subscript out ò range)
Nhờ Anh kiểm tra dùm em được không ạ
Cảm ơn Anh.

Chạy code trong file

th7 · 15/7/21

HieuCD đã viết:
Chạy code trong file

Em chào Anh HieuCD,
CODE của Anh không có vấn đề gì,
Nếu để mặc định vào file cũ thì không chạy được,
Nếu tạo file mới rồi bổ xung thêm hai Sheets "KE" và "RS" thì vẫn chạy bình thường,
Rất cảm ơn Anh HieuCD nha,

Lọc lấy dữ liệu cần trong tập tin .txt vào tập tin .xlsx (1 người xem)

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

Thành viên thường trực

File đính kèm

Thành viên gắn bó

File đính kèm

Thành viên gắn bó

File đính kèm

Thành viên thường trực

Hoàng Nhật Phương nha,​

File đính kèm

Thành viên gắn bó

Thành viên gắn bó

Thành viên thường trực

ongke0711​

File đính kèm

Thành viên tích cực

Thành viên gắn bó

Thành viên thường trực

Thành viên thường trực

Chuyên gia GPE

Thành viên thường trực

Chuyên gia GPE

File đính kèm

Thành viên thường trực

Đếm ngược thời gian

Hoàng Nhật Phương nha,

ongke0711