Tăng tốc đoạn code dò tìm theo điều kiện thời gian

[Haffaz Aladeen]

Chào cả nhà ạ.

Em đang làm thử 1 file excel có chức năng lọc tìm dữ liệu ở sheet "DATA CD", kiểm tra thời gian update nếu lớn hơn thời gian update của dữ liệu ở sheet "DATA" thì sẽ cập nhật cột Tiến độ.
Tuy nhiên thời gian chạy khá lâu, nên nhờ mọi người giúp em thử có cách nào nhanh hơn không ạ.

Em giải thích hơi khó kiểu, mọi người xem code trong file đính kèm giúp em.
Em cảm ơn!

 

[Haffaz Aladeen]

Chỉ có điều, ví dụ mã Order "S37" tương ứng cột Tiến độ có 3 kết quả, vậy bạn muốn lấy cái đầu tiên hay lấy cái cuối cùng?

Cái này em muốn lấy cái cuối cùng anh, cái có thời gian sau cùng đó

Bài đã được tự động gộp: 19/8/21

Nếu không muốn phân biệt chữ hoa, chữ thường, bạn thêm dòng này sau dòng:

Em cảm ơn anh ạ. Cho em làm phiền chút là nếu em thêm 1 chức năng nữa, đó là nếu "Số Order" nào đó có tiến độ là "O" thì cắt hết tất cả các dòng bên sheet "DATA CD" sang 1 sheet mới (ví dụ như "Sheet1" chẳng hạn ạ) và xóa cả dòng "Số Order" đó bên sheet "DATA" thì như thế nào anh ạ?

 

[Cá ngừ F1]

Cái này em muốn lấy cái cuối cùng anh, cái có thời gian sau cùng đó

Bài đã được tự động gộp: 19/8/21

Em cảm ơn anh ạ. Cho em làm phiền chút là nếu em thêm 1 chức năng nữa, đó là nếu "Số Order" nào đó có tiến độ là "O" thì cắt hết tất cả các dòng bên sheet "DATA CD" sang 1 sheet mới (ví dụ như "Sheet1" chẳng hạn ạ) và xóa cả dòng "Số Order" đó bên sheet "DATA" thì như thế nào anh ạ?

Nếu muốn lấy dòng cuối cùng, thử thay bằng code này, cũng không phân biệt chữ hoa chữ thường

Sub GPE_hehehe()
On Error Resume Next
Dim i&, DataCD(), SoOrder(), KQ(), Dic As Object, STT()
DataCD = Range(Sheets("DATA CD").[C2], Sheets("DATA CD").[I10000].End(3))
SoOrder = Range(Sheets("DATA").[B3], Sheets("DATA").[B10000].End(3))
ReDim KQ(1 To UBound(SoOrder), 1 To 4)
ReDim STT(1 To UBound(SoOrder), 1 To 1)
Set Dic = CreateObject("Scripting.Dictionary")
Dic.comparemode = vbTextCompare
For i = 1 To UBound(DataCD)
    If Not Dic.exists(CStr(DataCD(i, 1))) Then
        Dic.Add CStr(DataCD(i, 1)), i
    Else
        Dic(CStr(DataCD(i, 1))) = i
    End If
Next
For i = 1 To UBound(SoOrder)
    STT(i, 1) = i
    KQ(i, 1) = DataCD(Dic.Item(CStr(SoOrder(i, 1))), 2)
    KQ(i, 2) = DataCD(Dic.Item(CStr(SoOrder(i, 1))), 3)
    KQ(i, 3) = DataCD(Dic.Item(CStr(SoOrder(i, 1))), 4)
    KQ(i, 4) = DataCD(Dic.Item(CStr(SoOrder(i, 1))), 6)
Next
Sheets("DATA").[A3].Resize(i - 1, 1) = STT
Sheets("DATA").[C3].Resize(i - 1, 4) = KQ
End Sub

Với yêu cầu của bạn, Số order nào mà tiến độ bằng 0 thì bỏ đi, theo tôi thì phải làm sạch ngay từ nguồn Data CD, bằng 1 theo tác đơn giản, Filter rồi xóa phéng nó đi, thế có phải đơn giản không? thực ra thì viết code làm việc này cũng được.

 

[Haffaz Aladeen]

Nếu muốn lấy dòng cuối cùng, thử thay bằng code này, cũng không phân biệt chữ hoa chữ thường

Em cảm ơn anh nhiều ạ.

Với yêu cầu của bạn, Số order nào mà tiến độ bằng 0 thì bỏ đi, theo tôi thì phải làm sạch ngay từ nguồn Data CD, bằng 1 theo tác đơn giản, Filter rồi xóa phéng nó đi, thế có phải đơn giản không? thực ra thì viết code làm việc này cũng được.

Thì lúc đầu em cũng filter theo Số Order, nghiệt nỗi cũng phải chạy trong vòng lặp, gặp mã nào có Tiến độ là O thì mới cắt hết đi. Lại vướng phải vấn đề thời gian quá lâu anh ạ. Nên em nghỉ tiếp tục gán mảng (Của 1 Số Order, có thể 1 hoặc nhiều dòng) cho 1 key của dictionary, rồi mới chuyển qua sheet mới thì nhanh hơn. Tối nay em gửi code hiện tại lên nhờ mọi người xem giúp em với ạ.
Em cảm ơn!

 

[Cá ngừ F1]

Em cảm ơn anh nhiều ạ.

Thì lúc đầu em cũng filter theo Số Order, nghiệt nỗi cũng phải chạy trong vòng lặp, gặp mã nào có Tiến độ là O thì mới cắt hết đi. Lại vướng phải vấn đề thời gian quá lâu anh ạ. Nên em nghỉ tiếp tục gán mảng (Của 1 Số Order, có thể 1 hoặc nhiều dòng) cho 1 key của dictionary, rồi mới chuyển qua sheet mới thì nhanh hơn. Tối nay em gửi code hiện tại lên nhờ mọi người xem giúp em với ạ.
Em cảm ơn!

Code của tôi đã chạy theo đúng ý bạn chưa vậy?

 

[Haffaz Aladeen]

Code của tôi đã chạy theo đúng ý bạn chưa vậy?

Mục đích của em là lấy theo dòng có thời gian gần đây nhất (cùng số Order), Nên nếu em thêm dòng soft a-z cột thời gian thì kết quả sẽ đúng như mong muốn của em rồi đó ạ.
Cách này khá hay khi không cần so sánh thời gian
Em cảm ơn nhiều.

Bài đã được tự động gộp: 20/8/21

Em cảm ơn anh ạ. Cho em làm phiền chút là nếu em thêm 1 chức năng nữa, đó là nếu "Số Order" nào đó có tiến độ là "O" thì cắt hết tất cả các dòng bên sheet "DATA CD" sang 1 sheet mới (ví dụ như "Sheet1" chẳng hạn ạ) và xóa cả dòng "Số Order" đó bên sheet "DATA" thì như thế nào anh ạ?

Yêu cầu này của em kiểu như code trong file này ạ. DT2 là chưa chạy code, DT3 là kết quả ạ

 

[Cá ngừ F1]

Mục đích của em là lấy theo dòng có thời gian gần đây nhất (cùng số Order), Nên nếu em thêm dòng soft a-z cột thời gian thì kết quả sẽ đúng như mong muốn của em rồi đó ạ.
Cách này khá hay khi không cần so sánh thời gian
Em cảm ơn nhiều.

Bài đã được tự động gộp: 20/8/21

Yêu cầu này của em kiểu như code trong file này ạ. DT2 là chưa chạy code, DT3 là kết quả ạ

Thiệt tình là đọc code khó hiểu lắm đó bạn.
Giờ bạn muốn là theo số Order ở sheet Data, tham chiếu sang sheet DataCD để tìm các thông tin Mã Hàng, Số lượng, ... thời gian update (lấy theo bản ghi cuối cùng)

 

[Cá ngừ F1]

Bạn thử File này xem đúng ý không nhé, click GPE

Sub GPE()
On Error Resume Next
Dim i&, DataCD(), Order(), Dic As Object, STT(), Itm, KQ()
DataCD = Range(Sheet3.[C2], Sheet3.[I10000].End(3))
Order = Range(Sheet1.[B3], Sheet1.[B10000].End(3))
ReDim STT(1 To UBound(Order), 1 To 1)
ReDim KQ(1 To UBound(Order), 1 To 4)
Set Dic = CreateObject("Scripting.Dictionary")
Dic.comparemode = vbTextCompare
For i = 1 To UBound(DataCD)
    Itm = CStr(DataCD(i, 1))
    If Not Dic.exists(Itm) Then
        Dic.Add Itm, i
    Else
        Dic(Itm) = i
    End If
Next
For i = 1 To UBound(Order)
    STT(i, 1) = i
    KQ(i, 1) = DataCD(Dic.Item(Order(i, 1)), 2)
    KQ(i, 2) = DataCD(Dic.Item(Order(i, 1)), 3)
    KQ(i, 3) = DataCD(Dic.Item(Order(i, 1)), 4)
    KQ(i, 4) = DataCD(Dic.Item(Order(i, 1)), 6)
Next
With Sheet1
    .[A3].Resize(i - 1, 1) = STT
    .[C3].Resize(i - 1, 4) = KQ
End With
MsgBox "Done!"
End Sub

 

[vanthinh3101]

Mục đích của em là lấy theo dòng có thời gian gần đây nhất (cùng số Order), Nên nếu em thêm dòng soft a-z cột thời gian thì kết quả sẽ đúng như mong muốn của em rồi đó ạ.
Cách này khá hay khi không cần so sánh thời gian
Em cảm ơn nhiều.

Bài đã được tự động gộp: 20/8/21

Yêu cầu này của em kiểu như code trong file này ạ. DT2 là chưa chạy code, DT3 là kết quả ạ

File của bạn cứ có lỗi gì báo là không backup được.
Tôi copy ra 1 file mới.
Bạn thử xem file tôi gửi xem đúng ý không?
Tôi sửa dụng ADO, món này tôi học mà chưa thông

Sub Capnhattiendo()
    Dim cnn As Object, Rst As Object
    Dim strQuery As String, strQuery1 As String, strQuery2 As String, strQuery3 As String
    
    Application.ScreenUpdating = False
    
    Set cnn = CreateObject("ADODB.Connection")
    Set Rst = CreateObject("ADODB.Recordset")
    
    With cnn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0 Xml;HDR=No';"
        .Open
    End With
    
    'Cu phap Truy van tim Thoi gian lon nhat theo So Order cua Sheets("DATA CD")
    strQuery1 = _
            "SELECT " & _
                    " Ucase(f3) as [Order Number] " & _
                    ",Max(f8) as [Time] " & _
            "FROM [DATA CD$A2:I65000]" & _
            "GROUP BY Ucase(f3)"
    'Cu phap Truy van de tao ra bang voi So Order duy nhat va Thoi gian lon nhat
    strQuery1 = _
            "SELECT " & _
                    " dt2.[Order Number]" & _
                    ",dt1.f6 as [Progress]" & _
                    ",dt2.[Time] " & _
            "FROM [DATA CD$A2:I65000] AS dt1 " & _
            "INNER JOIN (" & _
                            strQuery1 & _
                        ") AS dt2 ON Ucase(dt1.f3) = dt2.[Order Number] " & _
                                        "AND dt1.f8 = dt2.[Time]"
    'Cu phap Truy van du lieu chung o Sheets("DATA CD") va Sheets("DATA"), cap theo theo Thoi gian lon nhat
    strQuery2 = _
            "SELECT " & _
                    " fdt.f1 AS [Stt]" & _
                    ",dt3.[Order Number]" & _
                    ",fdt.f3 AS [Key]" & _
                    ",fdt.f4 AS [Quantity]" & _
                    ",dt3.[Progress]" & _
                    ",dt3.[Time] " & _
            "FROM [DATA$A3:F65000] AS fdt " & _
            "INNER JOIN (" & _
                            strQuery1 & _
                            ") AS dt3 ON Ucase(fdt.f2) = dt3.[Order Number]"
    'Cu phap Truy van du lieu co o Sheets("DATA") nhung khong co o Sheets("DATA CD"), cap theo theo Thoi gian lon nhat
    strQuery3 = _
            "SELECT " & _
                    " fdt.f1 AS [Stt]" & _
                    ",fdt.f2 AS [Order Number]" & _
                    ",fdt.f3 AS [Key]" & _
                    ",fdt.f4 AS [Quantity]" & _
                    ",fdt.f5 AS [Progress]" & _
                    ",fdt.f6 AS [Time] " & _
            "FROM [DATA$A3:F65000] AS fdt " & _
            "LEFT OUTER JOIN (" & _
                            strQuery1 & _
                            ") AS dt3 " & _
                    "ON Ucase(fdt.f2) = dt3.[Order Number] WHERE dt3.[Order Number] is null"
    'Cu phap gop du lieu chung va rieng o 2 buoc tren de lay ket qua cuoi cung
    strQuery = _
            "(" & strQuery2 & ") " & _
            "UNION ALL" & _
            "(" & strQuery3 & ")" & _
            "ORDER BY [Stt]"
    
    Set Rst = cnn.Execute(strQuery)
    
    'Xoa ket qua cu, chi giu lai tieu de
    Sheet1.Range("A2:A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row).Offset(1).Resize(, 6).ClearContents
    'Dien ket qua truy van vao bang tinh
    Sheet1.Range("A3").CopyFromRecordset Rst
    'Dinh dang lai o Thoi gian update theo yeu cau
    Sheet1.Range("A3:A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row).Offset(, 5).NumberFormat = "dd/mm/yyyy hh:mm:ss"
    
    Set cnn = Nothing: Set Rst = Nothing

    Application.ScreenUpdating = True
    
    MsgBox "Done", vbInformation, "GPE"
End Sub

 

[Cá ngừ F1]

File của bạn cứ có lỗi gì báo là không backup được.
Tôi copy ra 1 file mới.
Bạn thử xem file tôi gửi xem đúng ý không?
Tôi sửa dụng ADO, món này tôi học mà chưa thông

Sub Capnhattiendo()
    Dim cnn As Object, Rst As Object
    Dim strQuery As String, strQuery1 As String, strQuery2 As String, strQuery3 As String
   
    Application.ScreenUpdating = False
   
    Set cnn = CreateObject("ADODB.Connection")
    Set Rst = CreateObject("ADODB.Recordset")
   
    With cnn
        .Provider = "Microsoft.ACE.OLEDB.12.0"
        .ConnectionString = "Data Source=" & ThisWorkbook.FullName & ";Extended Properties='Excel 12.0 Xml;HDR=No';"
        .Open
    End With
   
    'Cu phap Truy van tim Thoi gian lon nhat theo So Order cua Sheets("DATA CD")
    strQuery1 = _
            "SELECT " & _
                    " Ucase(f3) as [Order Number] " & _
                    ",Max(f8) as [Time] " & _
            "FROM [DATA CD$A2:I65000]" & _
            "GROUP BY Ucase(f3)"
    'Cu phap Truy van de tao ra bang voi So Order duy nhat va Thoi gian lon nhat
    strQuery1 = _
            "SELECT " & _
                    " dt2.[Order Number]" & _
                    ",dt1.f6 as [Progress]" & _
                    ",dt2.[Time] " & _
            "FROM [DATA CD$A2:I65000] AS dt1 " & _
            "INNER JOIN (" & _
                            strQuery1 & _
                        ") AS dt2 ON Ucase(dt1.f3) = dt2.[Order Number] " & _
                                        "AND dt1.f8 = dt2.[Time]"
    'Cu phap Truy van du lieu chung o Sheets("DATA CD") va Sheets("DATA"), cap theo theo Thoi gian lon nhat
    strQuery2 = _
            "SELECT " & _
                    " fdt.f1 AS [Stt]" & _
                    ",dt3.[Order Number]" & _
                    ",fdt.f3 AS [Key]" & _
                    ",fdt.f4 AS [Quantity]" & _
                    ",dt3.[Progress]" & _
                    ",dt3.[Time] " & _
            "FROM [DATA$A3:F65000] AS fdt " & _
            "INNER JOIN (" & _
                            strQuery1 & _
                            ") AS dt3 ON Ucase(fdt.f2) = dt3.[Order Number]"
    'Cu phap Truy van du lieu co o Sheets("DATA") nhung khong co o Sheets("DATA CD"), cap theo theo Thoi gian lon nhat
    strQuery3 = _
            "SELECT " & _
                    " fdt.f1 AS [Stt]" & _
                    ",fdt.f2 AS [Order Number]" & _
                    ",fdt.f3 AS [Key]" & _
                    ",fdt.f4 AS [Quantity]" & _
                    ",fdt.f5 AS [Progress]" & _
                    ",fdt.f6 AS [Time] " & _
            "FROM [DATA$A3:F65000] AS fdt " & _
            "LEFT OUTER JOIN (" & _
                            strQuery1 & _
                            ") AS dt3 " & _
                    "ON Ucase(fdt.f2) = dt3.[Order Number] WHERE dt3.[Order Number] is null"
    'Cu phap gop du lieu chung va rieng o 2 buoc tren de lay ket qua cuoi cung
    strQuery = _
            "(" & strQuery2 & ") " & _
            "UNION ALL" & _
            "(" & strQuery3 & ")" & _
            "ORDER BY [Stt]"
   
    Set Rst = cnn.Execute(strQuery)
   
    'Xoa ket qua cu, chi giu lai tieu de
    Sheet1.Range("A2:A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row).Offset(1).Resize(, 6).ClearContents
    'Dien ket qua truy van vao bang tinh
    Sheet1.Range("A3").CopyFromRecordset Rst
    'Dinh dang lai o Thoi gian update theo yeu cau
    Sheet1.Range("A3:A" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row).Offset(, 5).NumberFormat = "dd/mm/yyyy hh:mm:ss"
   
    Set cnn = Nothing: Set Rst = Nothing

    Application.ScreenUpdating = True
   
    MsgBox "Done", vbInformation, "GPE"
End Sub

có cái sự kiện workbook open đó Thịnh, xóa nó đi là được.
Dạo này chơi cả món ADO à, cái này anh chưa biết tí gì, hì

 

[vanthinh3101]

có cái sự kiện workbook open đó Thịnh, xóa nó đi là được.
Dạo này chơi cả món ADO à, cái này anh chưa biết tí gì, hì

Em cũng không để ý vụ sự kiện kia.
Em đang tranh thủ tìm hiểu thêm ADO, cái này hay a ạ

 

[Haffaz Aladeen]

Thiệt tình là đọc code khó hiểu lắm đó bạn.
Giờ bạn muốn là theo số Order ở sheet Data, tham chiếu sang sheet DataCD để tìm các thông tin Mã Hàng, Số lượng, ... thời gian update (lấy theo bản ghi cuối cùng)

Em kiểu viết theo kiểu logic của mình í, nên hơi lủng củng. Em viết nhằm 2 mục đích tách rời nhau (do 1 cái viết trước, 1 cái bổ sung sau)
1: Lấy tiến độ cuối cùng và thời gian (có thời gian gần nhất) ở bên sheet DATA CD sang sheet DATA (Số Order tương ứng)
2: Những Số Order nào có tiến độ là 5 ở bên sheet DATA CD thì sẽ cắt hết tất cả các dòng của Số Order này (kể cả tiến độ 1, 2, 3, ..) qua sheet TTTT và đồng thời xóa dòng chứa Số Order này bên sheet DATA (Theo code của em thì em chỉ tô màu đỏ cả dòng để test thử).

Bạn thử File này xem đúng ý không nhé, click GPE

Code này thì chỉ xóa những dòng của Số Order có tiến độ là 5 ở bên sheet DATA CD thôi ạ, em cần thêm là chuyển những dòng xóa này qua sheet TTTT và xóa dòng có Số Order tương ứng bên sheet DATA nữa ạ.

File của bạn cứ có lỗi gì báo là không backup được.

Anh @Cá ngừ F1 nói đúng đó ạ, do em thêm đoạn code backup vào thư mục ẩn trên mạng nội bộ công ty thôi ạ

Bài đã được tự động gộp: 20/8/21

Em cũng không để ý vụ sự kiện kia.
Em đang tranh thủ tìm hiểu thêm ADO, cái này hay a ạ

À với anh cho em hỏi về cái ADO này với ạ. Em cũng có làm 1 file update dữ liệu từ các sheet khác trên mạng nội bộ bằng ADO (Thực tế là copy về sửa đổi lại 1 chút thôi, chứ em cũng mù tịt). Nhưng nếu đôi lúc nó bị lỗi là mở hết hàng loạt các file con cần lấy dữ liệu lên dưới dạng ReadOnly, nhưng nếu tắt hết excel và cả excel chạy ngầm trong task manager nữa rồi chạy lại thì nó lại bình thường.
Theo em biết thì ADO cũng có mở ngầm file lên, nhưng không phải kiểu mở xong để đấy như này. Chứ em chạy xong lại tắt hàng loạt mất thời gian, đôi lúc lại còn bị lỗi nữa.
Em thử 1 vài máy khác thì có máy bị, máy không, rồi lại có lúc này lúc kia nữa. Anh có cách nào sửa được nó không ạ?
Em cũng mới chạy thử code của anh cũng bị lỗi như vậy. tắt hết Excel và excel chạy ngầm nữa thì lại OK, nên em nghỉ không phải lỗi do code ạ

 

[Cá ngừ F1]

Em kiểu viết theo kiểu logic của mình í, nên hơi lủng củng. Em viết nhằm 2 mục đích tách rời nhau (do 1 cái viết trước, 1 cái bổ sung sau)
1: Lấy tiến độ cuối cùng và thời gian (có thời gian gần nhất) ở bên sheet DATA CD sang sheet DATA (Số Order tương ứng)
2: Những Số Order nào có tiến độ là 5 ở bên sheet DATA CD thì sẽ cắt hết tất cả các dòng của Số Order này (kể cả tiến độ 1, 2, 3, ..) qua sheet TTTT và đồng thời xóa dòng chứa Số Order này bên sheet DATA (Theo code của em thì em chỉ tô màu đỏ cả dòng để test thử).

Code này thì chỉ xóa những dòng của Số Order có tiến độ là 5 ở bên sheet DATA CD thôi ạ, em cần thêm là chuyển những dòng xóa này qua sheet TTTT và xóa dòng có Số Order tương ứng bên sheet DATA nữa ạ.

Anh @Cá ngừ F1 nói đúng đó ạ, do em thêm đoạn code backup vào thư mục ẩn trên mạng nội bộ công ty thôi ạ

Từ từ, từng bước nhé:
B1: Tất cả bản ghi có tiến độ <=5 ở sheet DataCD thì cắt chuyển qua sheet TTTT?
B2: Nếu đã chuyển qua Sheet TTTT rồi, khi tham chiếu từ DataCD sang Data thì nó Blank hết, lúc đó xóa các dòng blank này đi?
Như vậy tôi có hiểu đúng ý không nhỉ?

 

[Haffaz Aladeen]

Từ từ, từng bước nhé:
B1: Tất cả bản ghi có tiến độ <=5 ở sheet DataCD thì cắt chuyển qua sheet TTTT?
B2: Nếu đã chuyển qua Sheet TTTT rồi, khi tham chiếu từ DataCD sang Data thì nó Blank hết, lúc đó xóa các dòng blank này đi?
Như vậy tôi có hiểu đúng ý không nhỉ?

Hic, em nói mọi người khó hiểu quá đó hay em ko hiểu ý của anh đó ạ
B1: Update tiến độ có thời gian gần nhất từ sheet DATA CD vào sheet DATA (Số Order tương ứng) và update ngày vào sheet DATA luôn. Chắc đoạn này anh hiểu em rồi ạ.
B2: Trong sheet DATA CD: Nếu Số Order nào có công đoạn là 5 (1 Số Order nhưng nhiều dòng, mỗi dòng lại có 1 Tiến Độ khác nhau) thì cắt tất cả các dòng cùng Số Order này sang sheet TTTT. Sau đó Sort lại để loại bỏ các dòng trắng (hoặc dùng cách khác là xóa các dòng trắng đi ạ)
B3: Trong sheet DATA: Xóa dòng có Số Order giống với số Order vừa cắt sang sheet TTTT (Tức là Số Order nào có ở bên sheet TTTT thì không có ở bên sheet DATA nữa đó ạ)
Anh sử dụng file DT2 đó ạ, file đó là file gốc, sau khi chạy code của em xong thì sẽ ra file DT3 đó ạ

 

[HieuCD]

Hic, em nói mọi người khó hiểu quá đó hay em ko hiểu ý của anh đó ạ
B1: Update tiến độ có thời gian gần nhất từ sheet DATA CD vào sheet DATA (Số Order tương ứng) và update ngày vào sheet DATA luôn. Chắc đoạn này anh hiểu em rồi ạ.
B2: Trong sheet DATA CD: Nếu Số Order nào có công đoạn là 5 (1 Số Order nhưng nhiều dòng, mỗi dòng lại có 1 Tiến Độ khác nhau) thì cắt tất cả các dòng cùng Số Order này sang sheet TTTT. Sau đó Sort lại để loại bỏ các dòng trắng (hoặc dùng cách khác là xóa các dòng trắng đi ạ)
B3: Trong sheet DATA: Xóa dòng có Số Order giống với số Order vừa cắt sang sheet TTTT (Tức là Số Order nào có ở bên sheet TTTT thì không có ở bên sheet DATA nữa đó ạ)
Anh sử dụng file DT2 đó ạ, file đó là file gốc, sau khi chạy code của em xong thì sẽ ra file DT3 đó ạ

Chạy sub Main để gọi lần lượt sub Update và LocTienDo

Sub Main()
  Call Update
  Call LocTienDo
End Sub

Sub Update()
  Dim aCD(), aData(), dic As Object
  Dim sRow&, i&, ik&, iKey$
 
  With Sheets("DATA CD")
    aCD = .Range("C2", .Range("H" & .Range("C65500").End(xlUp).Row)).Value
  End With
  With Sheets("DATA")
    aData = .Range("B3", .Range("F" & .Range("B65500").End(xlUp).Row)).Value
  End With
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  sRow = UBound(aCD)
  For i = 1 To sRow
    iKey = aCD(i, 1)
    If dic.exists(iKey) = False Then
      dic.Add iKey, Array(i, aCD(i, 6))
    ElseIf aCD(i, 6) > dic.Item(iKey)(1) Then
      dic.Item(iKey) = Array(i, aCD(i, 6))
    End If
  Next
  sRow = UBound(aData)
  For i = 1 To sRow
    iKey = aData(i, 1)
    If dic.exists(iKey) Then      
        If dic.Item(iKey)(1) > aData(i, 5) Then
          ik = dic.Item(iKey)(0)
          aData(i, 2) = aCD(ik, 2)
          aData(i, 3) = aCD(ik, 3)
          aData(i, 4) = aCD(ik, 4)
          aData(i, 5) = aCD(ik, 6)
        End If      
    End If
  Next
  Sheets("DATA").Range("B3").Resize(sRow, 5) = aData
End Sub

Sub LocTienDo()
  Dim aCD(), aData(), resCD(), dic As Object
  Dim sRow&, sCol&, i&, r&, r2&, k&
 
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  With Sheets("DATA CD")
    aCD = .Range("C2", .Range("I" & .Range("C65500").End(xlUp).Row)).Value
  End With
  sRow = UBound(aCD): sCol = UBound(aCD, 2)
  ReDim res(1 To sRow, 1 To sCol)
  For i = 1 To sRow
    iKey = aCD(i, 1)
    If aCD(i, 4) = 5 Then dic.Item(aCD(i, 1)) = ""
  Next i
  For i = 1 To sRow
    iKey = aCD(i, 1)
    If dic.exists(aCD(i, 1)) Then
      r = r + 1
      For j = 1 To sCol
        res(r, j) = aCD(i, j)
      Next j
    Else
      r2 = r2 + 1
      For j = 1 To sCol
        aCD(r2, j) = aCD(i, j)
      Next j
    End If
  Next i
  If r > 0 Then
    erow = Sheets("DATA CD").Range("C65500").End(xlUp).Row
    Sheets("DATA CD").Range("C2:I" & erow).ClearContents
    Sheets("DATA CD").Range("C2").Resize(r2, sCol) = aCD
    erow = Sheets("TTTT").Range("C65500").End(xlUp).Row
    If erow > 1 Then Sheets("TTTT").Range("C2:I" & erow).ClearContents
    Sheets("TTTT").Range("C2").Resize(r, sCol) = res
   
    With Sheets("DATA")
      aData = .Range("A3", .Range("F" & .Range("B65500").End(xlUp).Row)).Value
    End With
    sRow = UBound(aData): sCol = UBound(aData, 2)
    For i = 1 To sRow
      If dic.exists(aData(i, 2)) = False Then
        k = k + 1
        aData(k, 1) = k
        For j = 2 To sCol
          aData(k, j) = aData(i, j)
        Next j
      End If
    Next i
    erow = Sheets("DATA").Range("B65500").End(xlUp).Row
    Sheets("DATA").Range("A3:F" & erow).ClearContents
    Sheets("DATA").Range("A3").Resize(k, 6) = aData
  End If
End Sub

 

[Hoàng Nhật Phương]

Chạy sub Main để gọi lần lượt sub Update và LocTienDo

Sub Main()
  Call Update
  Call LocTienDo
End Sub

Sub Update()
  Dim aCD(), aData(), dic As Object
  Dim sRow&, i&, ik&, iKey$
 
  With Sheets("DATA CD")
    aCD = .Range("C2", .Range("H" & .Range("C65500").End(xlUp).Row)).Value
  End With
  With Sheets("DATA")
    aData = .Range("B3", .Range("F" & .Range("B65500").End(xlUp).Row)).Value
  End With
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  sRow = UBound(aCD)
  For i = 1 To sRow
    iKey = aCD(i, 1)
    If dic.exists(iKey) = False Then
      dic.Add iKey, Array(i, aCD(i, 6))
    ElseIf aCD(i, 6) > dic.Item(iKey)(1) Then
      dic.Item(iKey) = Array(i, aCD(i, 6))
    End If
  Next
  sRow = UBound(aData)
  For i = 1 To sRow
    iKey = aData(i, 1)
    If dic.exists(iKey) Then
      If dic.exists(iKey) Then
        If dic.Item(iKey)(1) > aData(i, 5) Then
          ik = dic.Item(iKey)(0)
          aData(i, 2) = aCD(ik, 2)
          aData(i, 3) = aCD(ik, 3)
          aData(i, 4) = aCD(ik, 4)
          aData(i, 5) = aCD(ik, 6)
        End If
      End If
    End If
  Next
  Sheets("DATA").Range("B3").Resize(sRow, 5) = aData
End Sub

Sub LocTienDo()
  Dim aCD(), aData(), resCD(), dic As Object
  Dim sRow&, sCol&, i&, r&, r2&, k&
 
  Set dic = CreateObject("Scripting.Dictionary")
  dic.comparemode = vbTextCompare
  With Sheets("DATA CD")
    aCD = .Range("C2", .Range("I" & .Range("C65500").End(xlUp).Row)).Value
  End With
  sRow = UBound(aCD): sCol = UBound(aCD, 2)
  ReDim res(1 To sRow, 1 To sCol)
  For i = 1 To sRow
    iKey = aCD(i, 1)
    If aCD(i, 4) = 5 Then dic.Item(aCD(i, 1)) = ""
  Next i
  For i = 1 To sRow
    iKey = aCD(i, 1)
    If dic.exists(aCD(i, 1)) Then
      r = r + 1
      For j = 1 To sCol
        res(r, j) = aCD(i, j)
      Next j
    Else
      r2 = r2 + 1
      For j = 1 To sCol
        aCD(r2, j) = aCD(i, j)
      Next j
    End If
  Next i
  If r > 0 Then
    erow = Sheets("DATA CD").Range("C65500").End(xlUp).Row
    Sheets("DATA CD").Range("C2:I" & erow).ClearContents
    Sheets("DATA CD").Range("C2").Resize(r2, sCol) = aCD
    erow = Sheets("TTTT").Range("C65500").End(xlUp).Row
    If erow > 1 Then Sheets("TTTT").Range("C2:I" & erow).ClearContents
    Sheets("TTTT").Range("C2").Resize(r, sCol) = res
 
    With Sheets("DATA")
      aData = .Range("A3", .Range("F" & .Range("B65500").End(xlUp).Row)).Value
    End With
    sRow = UBound(aData): sCol = UBound(aData, 2)
    For i = 1 To sRow
      If dic.exists(aData(i, 2)) = False Then
        k = k + 1
        aData(k, 1) = k
        For j = 2 To sCol
          aData(k, j) = aData(i, j)
        Next j
      End If
    Next i
    erow = Sheets("DATA").Range("B65500").End(xlUp).Row
    Sheets("DATA").Range("A3:F" & erow).ClearContents
    Sheets("DATA").Range("A3").Resize(k, 6) = aData
  End If
End Sub

Bác ơi , Bác chỉ con đoạn này với ạ:

...
      dic.Add iKey, Array(i, aCD(i, 6))
    ElseIf aCD(i, 6) > dic.Item(iKey)(1) Then
    ...

Ở dòng trên là: Array(i, aCD(i, 6)) theo con hiểu là một giá trị, còn ở dòng dưới Bác viết là: dic.Item(iKey)(1) , con không hiểu số (1) đằng sau ạ, nếu như dùng split thì con lại hiểu.
----------
À con hiểu rồi con không nhìn kỹ:
Array(i, aCD(i, 6)) là 2 phần tử khác với aCD(i, 6) là 1 phần tử.

 

[Haffaz Aladeen]

Chạy sub Main để gọi lần lượt sub Update và LocTienDo

Hay quá anh ạ.
Em cảm ơn nhiều nhiều!

 

[BuiQuangThuan]

@HieuCD cho em hỏi chút thầy ơi.

For i = 1 To sRow
    iKey = aData(i, 1)
    If dic.exists(iKey) Then
      If dic.exists(iKey) Then
        If dic.Item(iKey)(1) > aData(i, 5) Then
          ik = dic.Item(iKey)(0)
          aData(i, 2) = aCD(ik, 2)
          aData(i, 3) = aCD(ik, 3)
          aData(i, 4) = aCD(ik, 4)
          aData(i, 5) = aCD(ik, 6)
        End If
      End If
    End If
  Next

trong đoạn này thấy 2 cái kiểm tra dicc.exists(key) với mục đích gì thầy nhỉ.

 

[HieuCD]

@HieuCD cho em hỏi chút thầy ơi.

For i = 1 To sRow
    iKey = aData(i, 1)
    If dic.exists(iKey) Then
      If dic.exists(iKey) Then
        If dic.Item(iKey)(1) > aData(i, 5) Then
          ik = dic.Item(iKey)(0)
          aData(i, 2) = aCD(ik, 2)
          aData(i, 3) = aCD(ik, 3)
          aData(i, 4) = aCD(ik, 4)
          aData(i, 5) = aCD(ik, 6)
        End If
      End If
    End If
  Next

trong đoạn này thấy 2 cái kiểm tra dicc.exists(key) với mục đích gì thầy nhỉ.

Mình copy lệnh bị dư mắt mờ không thấy, đã chỉnh lại bài #34