Trích lọc dữ liệu sử dụng VBA Code

Liên hệ QC
HieuCD đã viết:
Tìm trên diễn đàn cách dùng ADO mở file CSV không thấy nên chấp nhận chạy chậm
Số dòng kết bị giới hạn, nếu có thông báo thì gởi file để viết tiếp code
Mã: 
Sub TongHop()
  Dim Wb As Workbook
  Dim pathStr As String, MyFile As String
  Dim Res() As String, sArr As Variant, dArr As Variant, S As Variant
  Dim i As Long, k As Long, eR As Long, n As Long, j As Byte

  Application.ScreenUpdating = False
  ReDim dArr(1 To 2, 1 To 1)
  pathStr = ThisWorkbook.Path 'Nhap duong dan truc tiep neu nam khac thu muc
  MyFile = Dir(pathStr & "\*.CSV")
  Do While MyFile <> ""
    k = k + 1
    ReDim Preserve dArr(1 To 2, 1 To k)
    dArr(1, k) = MyFile
    MyFile = Dir()
  Loop

  For n = 1 To k
    Set Wb = Workbooks.Open(pathStr & "\" & dArr(1, n), , True)
    If Len(Range("A1").Value) Then
      i = Range("A" & Rows.Count).End(xlUp).Row
      dArr(2, n) = Range("A1:A" & i).Value
      eR = eR + i
    End If
    Wb.Close
  Next n

  If eR Then
    k = 0
    ReDim Res(1 To eR, 1 To 5)
    For n = 1 To UBound(dArr, 2)
      sArr = dArr(2, n)
      If IsArray(sArr) Then
        For i = 1 To UBound(sArr)
          If Len(sArr(i, 1)) Then
            k = k + 1
            S = Split(sArr(i, 1), ";")
            For j = 0 To UBound(S)
              Res(k, j + 1) = S(j)
            Next j
          End If
        Next i
      End If
    Next n
  End If
  i = Range("A" & Rows.Count).End(xlUp).Row
  If i > 2 Then Range("A3:E" & i).ClearContents
  If k > 1048570 Then
    MsgBox ("Du leu qua lon, can viet lai code, tam lay mot so dong")
    k = 1048570
  End If
  Range("A3:E3").Resize(k) = Res
  Application.ScreenUpdating = True
End Sub
Nhấp chuột vào đây để mở rộng...

Qúa nhanh, quá nguy hiểm. Cám ơn anh HieuCD đã nhiệt tình hỗ trợ kịp thời.
Code của anh chạy tốt và cũng không thấy chậm gì. Đối với bài toán ban đầu đặt ra thì anh đã giúp đỡ giải quyết xong.
Tuy nhiên từ những doạn code này lại làm mình đam mê với VBA. Mình sẽ nghiên cứu đoạn code này để học hỏi, tùy chỉnh. Nếu có gì không hiểu, rất mong anh HieuCD chỉ giúp.
Một lần nữa xin cám ơn anh HieuCD và ban quản trị https://www.giaiphapexcel.com đã có những bài viết, những hỗ trợ nhiệt tình cho mọi người có thêm những bài học và kiến thức quý báu.
 
Lần chỉnh sửa cuối:
Xin lỗi vi kiểm tra không kĩ
 
HieuCD đã viết:
Chỉnh code
Mã: 
Sub Main()
  Dim sArr As Variant, dArr As Variant, Res As Variant, s As Variant
  Dim ProName 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) = sArr(1, 1) & "1"

  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) = sArr(1, 1) & "2"
        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(1, 7) = Res(1, 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(1, 7) + Res(nR, 7)
  End With
  [B7].Resize(k, 6).NumberFormat = "@"
  [B7].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 Byte, n As Byte, sC As Byte

  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, 20), ".")(0))
        Else
          Res(1, 1) = Res(1, 1) & "-" & Application.Trim(Mid(str, j, 20))
          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
Nhấp chuột vào đây để mở rộng...
Chào Anh HieuCD,
Ở trên là CODE Anh có chỉnh sửa phù hợp,
Hiện tại phần mềm bên em lên đời mới và khi xuất file ra nó có thêm một số thông tin, và em sử dụng code hiện tại thì bị lỗi,
Nhờ Anh xem qua vị trí bị lỗi và hướng dẫn em tiếp các bước tiếp theo không ah,
Thanks Anh.
 

File đính kèm

  • 123456789-A_113A_New.txt
    32.2 KB · Đọc: 2
  • 987654321-A_106A_Old.txt
    17.7 KB · Đọc: 2
  • FSS_REV00.xlsm
    31 KB · Đọc: 2
thehoang7 đã viết:
Chào Anh HieuCD,
Ở trên là CODE Anh có chỉnh sửa phù hợp,
Hiện tại phần mềm bên em lên đời mới và khi xuất file ra nó có thêm một số thông tin, và em sử dụng code hiện tại thì bị lỗi,
Nhờ Anh xem qua vị trí bị lỗi và hướng dẫn em tiếp các bước tiếp theo không ah,
Cảm ơn Anh.
Nhấp chuột vào đây để mở rộng...
Lâu quá không nhớ rỏ yêu cầu
Bạn làm tay kết quả thật chuẩn gởi lên mình sẽ mò lại
 
HieuCD đã viết:
Lâu quá không nhớ rỏ yêu cầu
Bạn làm tay kết quả thật chuẩn gởi lên mình sẽ mò lại
Nhấp chuột vào đây để mở rộng...
HI Anh HieuCD,
Em gửi Anh file đính kèm nha,
File .xls "KQ_FSS" có hai Sheets "Line KE" và"Line RS" là kết quả mong muốn, nhờ Anh xem với file .txt thì mình có sử dụng chung một VBA Code được không?
File .txt là file dữ liệu cho từng line
Cảm ơn Anh.
 

File đính kèm

  • 10023578-A-RS.txt
    43.7 KB · Đọc: 5
  • 10023578-A-KE.txt
    43.7 KB · Đọc: 4
  • KQ_FSS.xls
    51.5 KB · Đọc: 2
thehoang7 đã viết:
HI Anh HieuCD,
Em gửi Anh file đính kèm nha,
File .xls "KQ_FSS" có hai Sheets "Line KE" và"Line RS" là kết quả mong muốn, nhờ Anh xem với file .txt thì mình có sử dụng chung một VBA Code được không?
File .txt là file dữ liệu cho từng line
Cảm ơn Anh.
Nhấp chuột vào đây để mở rộng...
Chạy code, chọn 1 hoặc 2 file text, bấm Ok
Code không bẩy lỗi chọn sai file text
Mã: 
Sub Main()
  Dim aSheets(), Res(), Dic As Object
  Dim FilesToOpen$, shName$
  Dim i&, n&, k&
  Dim Chk As Boolean
 
  Chk = Application.FileDialog(msoFileDialogFilePicker).Show
  If Not Chk Then Exit Sub
  aSheets = Array("Line KE", "Line RS")
  Set Dic = CreateObject("scripting.dictionary")
  With Application.FileDialog(msoFileDialogFilePicker).SelectedItems
    For n = 1 To .Count
      FilesToOpen = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(n)
      Call CreatRes(Res, Dic, shName, k, FilesToOpen)
      Dic.RemoveAll
      For i = 0 To 1
        If aSheets(i) = "Line " & shName Then
          With Sheets(aSheets(i))
            .UsedRange.ClearContents
            .Range("C2").Resize(k).NumberFormat = "@"
            .Range("B2").Resize(k, 7) = Res
          End With
        End If
      Next i
    Next n
  End With
End Sub

Private Sub CreatRes(Res, Dic, shName, k, ByVal FilesToOpen As String)
  Dim fso As Object, TextSource As Object
  Dim S, tArr, Sign(), iCol()
  Dim str$, tmp$, iKey$, prName$ 'khai bao bien String
  Dim i&, fR&, fR2&, eR&, n&  ' khai bao bien long, no byte, loi overflow
 
  Set fso = CreateObject("Scripting.FileSystemObject") ' khoi tao cong cu FSO
  Set TextSource = fso.OpenTextFile(FilesToOpen, 1, False, -2) ' default
  tArr = Split(TextSource.ReadAll, vbCrLf) ' default
 
  ReDim Res(1 To UBound(tArr), 1 To 8)
  ReDim sArr(1 To UBound(tArr), 1 To 2)
  For i = LBound(tArr) To UBound(tArr)
    str = tArr(i)
    If InStr(str, "Program Name") Then
      prName = Replace((Split(Split(str, "=")(1), ".")(0)), " ", "")
    ElseIf InStr(str, "Line Name") Then
      S = Split(str, "=")
      shName = Replace(S(UBound(S)), " ", "")
      prName = shName & "-" & prName
      fR = i + 1: Exit For
    End If
  Next i
 
  Sign = Array("Feeder Position", "Component Name", "Comment", " Type", "Component pitch", "Lane")
  ReDim iCol(LBound(Sign) To UBound(Sign))
  For i = fR To UBound(tArr)
    str = tArr(i)
    If InStr(str, Sign(0)) Then
      eR = i - 1
      For n = LBound(Sign) To UBound(Sign)
        iCol(n) = InStr(str, Sign(n))
      Next n
      fR2 = i: Exit For
    End If
  Next i
  k = 0
  For i = fR2 To UBound(tArr)
    str = tArr(i)
    If InStr(str, Sign(0)) Then
      k = k + 1: m = m + 1: ik = k
      Res(k, 1) = "Program Name: " & m & prName
      Res(k, 4) = "Simulate time(s)"
      Res(k, 6) = "No. of comp.ts"
      For n = i - 2 To i - 1
        If InStr(tArr(n), "Machine") Then
          Res(k, 3) = Application.Trim(tArr(n))
          Exit For
        End If
      Next n
    ElseIf Mid(Application.Trim(str), 2, 1) = "-" Then
      k = k + 1
      Res(k, 1) = Application.Trim(Mid(str, iCol(0), iCol(1) - iCol(0)))
      iKey = Application.Trim(Mid(str, iCol(1), iCol(2) - iCol(1)))
      Dic.Item(iKey) = Array(k, ik)
      S = Split(iKey, " ")
      Res(k, 2) = S(1): Res(k, 4) = S(0)
      tmp = Application.Trim(Mid(str, iCol(3), iCol(4) - iCol(3)))
      Res(k, 5) = Mid(tmp, InStr(1, tmp, " ") + 1, Len(tmp))
      Res(k, 6) = Split(Application.Trim(Mid(str, iCol(4), iCol(5) - iCol(4))), " ")(0)
    End If
  Next i
 
  Sign = Array("Placement ID", "X", "Component Name", "Centering")
  ReDim iCol(LBound(Sign) To UBound(Sign))
  For i = fR To eR
    str = tArr(i)
    If InStr(str, Sign(0)) Then
      For n = LBound(Sign) To UBound(Sign)
        iCol(n) = InStr(str, Sign(n))
      Next n
      fR = i + 1: Exit For
    End If
  Next i
  k = k + 1
  Res(k, 6) = "Total placements"
  For i = fR To UBound(tArr)
    str = tArr(i)
    iKey = Application.Trim(Mid(str, iCol(2), iCol(3) - iCol(2)))
    S = Dic.Item(iKey)
    If TypeName(S) = "Variant()" Then
      If Res(S(0), 3) = Empty Then
        Res(S(0), 3) = Application.Trim(Mid(str, iCol(0), iCol(1) - iCol(0)))
      Else
        Res(S(0), 3) = Res(S(0), 3) & "," & Application.Trim(Mid(str, iCol(0), iCol(1) - iCol(0)))
      End If
      Res(S(0), 7) = Res(S(0), 7) + 1
      Res(S(1), 7) = Res(S(1), 7) + 1
      Res(k, 7) = Res(k, 7) + 1
    End If
  Next i
  Set fso = Nothing: Set TextSource = Nothing
End Sub
 

File đính kèm

  • KQ_FSS.xlsb
    52 KB · Đọc: 7
HieuCD đã viết:
Chạy code, chọn 1 hoặc 2 file text, bấm Ok
Code không bẩy lỗi chọn sai file text
Mã: 
Sub Main()
  Dim aSheets(), Res(), Dic As Object
  Dim FilesToOpen$, shName$
  Dim i&, n&, k&
  Dim Chk As Boolean

  Chk = Application.FileDialog(msoFileDialogFilePicker).Show
  If Not Chk Then Exit Sub
  aSheets = Array("Line KE", "Line RS")
  Set Dic = CreateObject("scripting.dictionary")
  With Application.FileDialog(msoFileDialogFilePicker).SelectedItems
    For n = 1 To .Count
      FilesToOpen = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(n)
      Call CreatRes(Res, Dic, shName, k, FilesToOpen)
      Dic.RemoveAll
      For i = 0 To 1
        If aSheets(i) = "Line " & shName Then
          With Sheets(aSheets(i))
            .UsedRange.ClearContents
            .Range("C2").Resize(k).NumberFormat = "@"
            .Range("B2").Resize(k, 7) = Res
          End With
        End If
      Next i
    Next n
  End With
End Sub

Private Sub CreatRes(Res, Dic, shName, k, ByVal FilesToOpen As String)
  Dim fso As Object, TextSource As Object
  Dim S, tArr, Sign(), iCol()
  Dim str$, tmp$, iKey$, prName$ 'khai bao bien String
  Dim i&, fR&, fR2&, eR&, n&  ' khai bao bien long, no byte, loi overflow

  Set fso = CreateObject("Scripting.FileSystemObject") ' khoi tao cong cu FSO
  Set TextSource = fso.OpenTextFile(FilesToOpen, 1, False, -2) ' default
  tArr = Split(TextSource.ReadAll, vbCrLf) ' default

  ReDim Res(1 To UBound(tArr), 1 To 8)
  ReDim sArr(1 To UBound(tArr), 1 To 2)
  For i = LBound(tArr) To UBound(tArr)
    str = tArr(i)
    If InStr(str, "Program Name") Then
      prName = Replace((Split(Split(str, "=")(1), ".")(0)), " ", "")
    ElseIf InStr(str, "Line Name") Then
      S = Split(str, "=")
      shName = Replace(S(UBound(S)), " ", "")
      prName = shName & "-" & prName
      fR = i + 1: Exit For
    End If
  Next i

  Sign = Array("Feeder Position", "Component Name", "Comment", " Type", "Component pitch", "Lane")
  ReDim iCol(LBound(Sign) To UBound(Sign))
  For i = fR To UBound(tArr)
    str = tArr(i)
    If InStr(str, Sign(0)) Then
      eR = i - 1
      For n = LBound(Sign) To UBound(Sign)
        iCol(n) = InStr(str, Sign(n))
      Next n
      fR2 = i: Exit For
    End If
  Next i
  k = 0
  For i = fR2 To UBound(tArr)
    str = tArr(i)
    If InStr(str, Sign(0)) Then
      k = k + 1: m = m + 1: ik = k
      Res(k, 1) = "Program Name: " & m & prName
      Res(k, 4) = "Simulate time(s)"
      Res(k, 6) = "No. of comp.ts"
      For n = i - 2 To i - 1
        If InStr(tArr(n), "Machine") Then
          Res(k, 3) = Application.Trim(tArr(n))
          Exit For
        End If
      Next n
    ElseIf Mid(Application.Trim(str), 2, 1) = "-" Then
      k = k + 1
      Res(k, 1) = Application.Trim(Mid(str, iCol(0), iCol(1) - iCol(0)))
      iKey = Application.Trim(Mid(str, iCol(1), iCol(2) - iCol(1)))
      Dic.Item(iKey) = Array(k, ik)
      S = Split(iKey, " ")
      Res(k, 2) = S(1): Res(k, 4) = S(0)
      tmp = Application.Trim(Mid(str, iCol(3), iCol(4) - iCol(3)))
      Res(k, 5) = Mid(tmp, InStr(1, tmp, " ") + 1, Len(tmp))
      Res(k, 6) = Split(Application.Trim(Mid(str, iCol(4), iCol(5) - iCol(4))), " ")(0)
    End If
  Next i

  Sign = Array("Placement ID", "X", "Component Name", "Centering")
  ReDim iCol(LBound(Sign) To UBound(Sign))
  For i = fR To eR
    str = tArr(i)
    If InStr(str, Sign(0)) Then
      For n = LBound(Sign) To UBound(Sign)
        iCol(n) = InStr(str, Sign(n))
      Next n
      fR = i + 1: Exit For
    End If
  Next i
  k = k + 1
  Res(k, 6) = "Total placements"
  For i = fR To UBound(tArr)
    str = tArr(i)
    iKey = Application.Trim(Mid(str, iCol(2), iCol(3) - iCol(2)))
    S = Dic.Item(iKey)
    If TypeName(S) = "Variant()" Then
      If Res(S(0), 3) = Empty Then
        Res(S(0), 3) = Application.Trim(Mid(str, iCol(0), iCol(1) - iCol(0)))
      Else
        Res(S(0), 3) = Res(S(0), 3) & "," & Application.Trim(Mid(str, iCol(0), iCol(1) - iCol(0)))
      End If
      Res(S(0), 7) = Res(S(0), 7) + 1
      Res(S(1), 7) = Res(S(1), 7) + 1
      Res(k, 7) = Res(k, 7) + 1
    End If
  Next i
  Set fso = Nothing: Set TextSource = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Hi Anh HieuCD
Code Chạy rất ổn ạ,
Cảm ơn Anh rất nhiều.
 
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

dungluf123
Lỗi khi sử dụng công thức để link từ file này sang file khác của Excel trên hệ thống mạng chung của công ty
Trả lời
0
Đọc
21
dungluf123
dungluf123
V
Tìm điều kiện sau đó tính tổng ma hang theo điều kiện
Trả lời
5
Đọc
46
vnproc
V
hongphuong1997
  • Question
Lấy ký tự trong chuỗi theo nhiều điều kiện
Trả lời
0
Đọc
26
hongphuong1997
hongphuong1997
P
HÀM SUBTOTAL BỊ #VALUE
Trả lời
1
Đọc
26
DeTong
D
phanmoi688
[Xin nhờ giúp đỡ] Tìm cách xóa các ký tự trắng trong biểu
Trả lời
4
Đọc
46
phanmoi688
phanmoi688
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

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

Back
Top Bottom