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

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)
H

Haffaz Aladeen

Thành viên mới
Tham gia
11/7/18
Bài viết
41
Được thích
5
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!
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Haffaz Aladeen đã viết:
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!
Nhấp chuột vào đây để mở rộng...
Bạn thử với cái này:

Mã: 
Sub NhapCongDoan()
    Dim i1 As Range
    Dim t1, t0, t As Long
    
    On Error Resume Next
    'With Sheet14
    '    n1 = .Cells(.Rows.Count, "B").End(xlUp).Row
    'End With
    Set Rng = Sheet1.Range(Sheet1.[B3], Sheet1.[B15000].End(xlUp))
    Set Rng1 = Sheet3.Range(Sheet3.[C2], Sheet3.[C60000].End(xlUp))
        't0 = Sheet1.Range("C1").Value
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    
        For Each i1 In Rng1
            t1 = Format(i1.Offset(, 5), "0.0000000000")
            t0 = Format(Rng.Find(i1.Value, LookIn:=xlValues, lookat:=xlWhole).Offset(, 4).Value, "0.0000000000")
            cd1 = i1.Offset(, 3).Value
            If t1 > t0 Then
                Rng.Find(i1.Value, LookIn:=xlValues, lookat:=xlWhole).Offset(, 3).Value = cd1
                Rng.Find(i1.Value, LookIn:=xlValues, lookat:=xlWhole).Offset(, 4).Value = i1.Offset(, 5).Value
                    'Format(t1, "dd/mm/yy hh:mm:ss")
            End If
        Next i1
        
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    't1 = sheet14.Range("B" & i1).Find(
End Sub
 
Upvote 0
Haffaz Aladeen đã viết:
Hay quá anh ạ, mấy dòng này cũng có nghe nói, mà em chưa thử nghiệm bao giờ. Không ngờ nhanh hơn nhiều thế
Em cảm ơn nhé.

Ngoài ra thì còn cách nào khác nữa không anh nhỉ?
Nhấp chuột vào đây để mở rộng...
Có lẽ là còn, nhưng chăc làm cái này tôi hiện không rảnh, để người khác xem và giúp bạn nhé.
 
Upvote 0
Haffaz Aladeen đã viết:
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!
Nhấp chuột vào đây để mở rộng...
Bạn ơi,
Bạn có thể giải thích mong muốn của bạn rõ ràng là gì được không?
Nhìn code của bạn tôi chỉ hiểu được là tìm thời gian bên ở sheet "DATA CD" của mã sOder rồi kiểm tra xem bên sheet Data thời gian này có lớn hơn với thời gian tìm kiếm đã cho trước của mã số oder đó hay không nếu lớn hơn thì update thông tin theo sheet "DATA CD".
Code của bạn có phải chỉ làm vậy thôi đúng không?
Ví dụ trong sheet "DATA CD" bạn có đến 8 giá trị "435" phải duyệt hết từng 8 giá trị này xem giá trị nào có thời gian hoàn thành lớn nhất và lớn hơn thời gian của số oder bên sheet data thì điền sang ?
1629292981906.png

Nhưng điểm vấn đề là,trong sheet data bạn lại có 2 dòng số oder "435":
1629293123683.png

Mà trong khi code của bạn thi luôn tìm kiếm giá trị i1.Value = "435"
Mã: 
        t1 = Format(i1.Offset(, 5), "0.0000000000")
        t0 = Format(Rng.Find(i1.Value, LookIn:=xlValues, lookat:=xlWhole).Offset(, 4).Value, "0.0000000000")
        If t1 < t0 Then
Phải chăng nó luôn tìm thấy dòng 329 (dòng trước) để so sánh và điền kết quả vào dòng 329 này nếu thời gian lớn hơn , còn dòng 813 không quan tâm?
 
Upvote 0
Hoàng Nhật Phương đã viết:
Bạn ơi,
Bạn có thể giải thích mong muốn của bạn rõ ràng là gì được không?
Nhìn code của bạn tôi chỉ hiểu được là tìm thời gian bên ở sheet "DATA CD" của mã sOder rồi kiểm tra xem bên sheet Data thời gian này có lớn hơn với thời gian tìm kiếm đã cho trước của mã số oder đó hay không nếu lớn hơn thì update thông tin theo sheet "DATA CD".
Code của bạn có phải chỉ làm vậy thôi đúng không?
Ví dụ trong sheet "DATA CD" bạn có đến 8 giá trị "435" phải duyệt hết từng 8 giá trị này xem giá trị nào có thời gian hoàn thành lớn nhất và lớn hơn thời gian của số oder bên sheet data thì điền sang ?
Nhấp chuột vào đây để mở rộng...
Đúng là như thế đó bạn. Do file của mình còn nhiều thứ hơn, nên mình rút gọn dữ liệu lại chỉ lấy 3 số đó. Chứ theo nguyên tắc thì cột Số Order không được trùng nhau đâu bạn ạ
Bài đã được tự động gộp:

Ai biết cách nào khác giúp em với ạ
 
Upvote 0
Haffaz Aladeen đã viết:
Đúng là như thế đó bạn. Do file của mình còn nhiều thứ hơn, nên mình rút gọn dữ liệu lại chỉ lấy 3 số đó. Chứ theo nguyên tắc thì cột Số Order không được trùng nhau đâu bạn ạ
Bài đã được tự động gộp:

Ai biết cách nào khác giúp em với ạ
Nhấp chuột vào đây để mở rộng...
Bạn kiểm tra lại nhé:
Mã: 
Option Explicit

Sub update_tiendo()

    Dim shCD As Worksheet, shData As Worksheet, time_1 As Double, time_2 As Double
    Dim r As Long, i As Long, sTienDo As String, sOder As String, arrCD(), arrData()

    Set shCD = ThisWorkbook.Worksheets("DATA CD")
    r = shCD.Cells(shCD.Rows.Count, "C").End(xlUp).Row
    If r < 2 Then Exit Sub
    arrCD = shCD.Range("C2:C" & r).Resize(, 7).Value
    
    Set shData = ThisWorkbook.Worksheets("DATA")
    r = shData.Cells(shData.Rows.Count, "B").End(xlUp).Row
    If r < 3 Then Exit Sub
    arrData = shData.Range("B3:F" & r).Resize(, 5).Value
    
    Dim dic As New Scripting.Dictionary
    
    For i = LBound(arrData, 1) To UBound(arrData, 1)
        sOder = arrData(i, 1)
        If Not dic.Exists(sOder) Then
            dic.Add sOder, i
        End If
    Next i
    
    For i = LBound(arrCD, 1) To UBound(arrCD, 1)
        sOder = arrCD(i, 1)
        If dic.Exists(sOder) Then
            r = dic.Item(sOder)
            sTienDo = arrCD(i, 4)
            time_1 = arrCD(i, 6)
            time_2 = arrData(r, 5)
            If time_1 > time_2 Then
                arrData(r, 5) = time_1
                arrData(r, 4) = sTienDo
            End If
        End If
    Next i
    
    shData.Range("B3").Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    
End Sub
 
Upvote 0
Haffaz Aladeen đã viết:
Hay quá anh ạ, mấy dòng này cũng có nghe nói, mà em chưa thử nghiệm bao giờ. Không ngờ nhanh hơn nhiều thế
Em cảm ơn nhé.

Ngoài ra thì còn cách nào khác nữa không anh nhỉ?
Nhấp chuột vào đây để mở rộng...
Không biết kết quả có đúng không? bạn thử test lại kết quả xem thế nào
Mã: 
Sub ABC()
    Dim Dic As Object, Arr(), sArr(), iR&, i&, Key, J&, T, Res()
    Set Dic = CreateObject("scripting.dictionary")
    With Sheets("DATA")
        iR = .Range("B" & Rows.Count).End(3).Row
        Arr = .Range("B3:F" & iR).Value
    End With
    ReDim Res(1 To UBound(Arr, 1), 1 To 2)
    For i = 1 To UBound(Arr, 1)
        Key = Arr(i, 1) & "|" & Arr(i, 2) & "|" & Arr(i, 4)
        If Dic.exists(Key) = False Then
            Dic.Item(Key) = i
            Res(i, 1) = Arr(i, 4)
            Res(i, 2) = Arr(i, 5)
        End If
    Next
    With Sheets("DATA CD")
        iR = .Range("C" & Rows.Count).End(3).Row
        sArr = .Range("C2:I" & iR).Value
        For i = 1 To UBound(sArr, 1)
            Key = sArr(i, 1) & "|" & sArr(i, 2) & "|" & sArr(i, 4)
            If Dic.exists(Key) Then
                J = Dic.Item(Key)
                If Format(sArr(i, 6), "0.0000000000") > Format(Arr(J, 5), "0.0000000000") Then
                    Res(J, 2) = sArr(i, 6)
                End If
            End If
        Next
    End With
    Sheet1.Range("G3").Resize(UBound(Arr, 1), 2).Value = Res
End Sub
 
Upvote 0
Hoàng Nhật Phương đã viết:
Bạn kiểm tra lại nhé:
Nhấp chuột vào đây để mở rộng...
Cột thời gian update thì đã chạy đúng rồi, nhưng có một số vị trí bị thay đổi dữ liệu như ở cột Số Order và mã hàng đó anh
buiquangthuan đã viết:
Không biết kết quả có đúng không? bạn thử test lại kết quả xem thế nào
Nhấp chuột vào đây để mở rộng...
Kết quả quá hoàn hảo ạ. Em cảm ơn mọi người nhiều.

Giờ thì từ từ nghiền ngẫm code thôi. Nhưng cho em hỏi 1 vấn đề là: Tại sao 2 code đều dùng scriping.Dictionary, nhưng của anh Hoàng Nhật Phương lại phải add thư viện, nhưng của anh buiquangthuan thì không nhỉ?
 
Upvote 0
Haffaz Aladeen đã viết:
Kết quả quá hoàn hảo ạ. Em cảm ơn mọi người nhiều.

Giờ thì từ từ nghiền ngẫm code thôi. Nhưng cho em hỏi 1 vấn đề là: Tại sao 2 code đều dùng scriping.Dictionary, nhưng của anh Hoàng Nhật Phương lại phải add thư viện, nhưng của anh buiquangthuan thì không nhỉ?
Nhấp chuột vào đây để mở rộng...
Kết quả đúng á. Sao mình so sánh với cái code cũ của bạn chạy nó có cái chệch. Làm theo dạng trúng thì trúng chẳng trúng thì trượt. Code cua Anh Thơ logic giống y chang của mình. Cái khởi tạo dictionary thì mỗi người viết 1 cách. Nếu trong tool VBA mà chưa kích vô cái scripting ...... Gì đó thì hình như của anh thơ sẽ chạy được sao ấy.
 
Upvote 0
Haffaz Aladeen đã viết:
Cột thời gian update thì đã chạy đúng rồi, nhưng có một số vị trí bị thay đổi dữ liệu như ở cột Số Order và mã hàng đó anh

Kết quả quá hoàn hảo ạ. Em cảm ơn mọi người nhiều.

Giờ thì từ từ nghiền ngẫm code thôi. Nhưng cho em hỏi 1 vấn đề là: Tại sao 2 code đều dùng scriping.Dictionary, nhưng của anh Hoàng Nhật Phương lại phải add thư viện, nhưng của anh buiquangthuan thì không nhỉ?
Nhấp chuột vào đây để mở rộng...
À mà em tìm thấy tài liệu của anh Kyo trên diễn đàn về scriping.Dictionary rồi ạ
www.giaiphapexcel.com

Tổng quan về Scripting.Dictionary

Với những ai yêu thích Excel nói chung và yêu thích VBA nói riêng thì chắc hẳn cũng đã biết qua các khái niệm về mảng, về công thức điều kiện, vòng lặp,..., những thứ rất quen thuộc mà gần như là sử dụng thường xuyên trong từng bài toán lập trình. Tuy nhiên, có lẽ sẽ rất ít người biết về...
www.giaiphapexcel.com www.giaiphapexcel.com
Bài đã được tự động gộp:

buiquangthuan đã viết:
Kết quả đúng á. Sao mình so sánh với cái code cũ của bạn chạy nó có cái chệch. Làm theo dạng trúng thì trúng chẳng trúng thì trượt. Code cua Anh Thơ logic giống y chang của mình. Cái khởi tạo dictionary thì mỗi người viết 1 cách. Nếu trong tool VBA mà chưa kích vô cái scripting ...... Gì đó thì hình như của anh thơ sẽ chạy được sao ấy.
Nhấp chuột vào đây để mở rộng...
Bị lệch là do file mẫu của em bị sai đó anh, đúng là cột Số Order phải không có dữ liệu trùng nhau. Nếu sửa dữ liệu lại thì kết quả giống nhau ạ
 
Lần chỉnh sửa cuối:
Upvote 0
Haffaz Aladeen đã viết:
Cột thời gian update thì đã chạy đúng rồi, nhưng có một số vị trí bị thay đổi dữ liệu như ở cột Số Order và mã hàng đó anh
......
Giờ thì từ từ nghiền ngẫm code thôi.
Nhấp chuột vào đây để mở rộng...
Bạn thử lại:
Mã: 
Option Explicit     '// Them dong nay de kiem soat cac bien co duoc din nghia day hay khong?
Sub Capnhat_Thoigian()                                  '// Ten thu tuc
    '//Khai bao bien
    Dim dic As Object, arrCD(), arrData(), rData As Range, sKey As String, r As Long, i As Long
    With ThisWorkbook.Worksheets("DATA CD")             '// Lam viec voi Sheet "DATA CD"
        r = .Cells(.Rows.Count, "C").End(xlUp).Row      '// Xac dinh dong cuoi trong co C
        If r < 2 Then Exit Sub                          '// Thoat neu khong co du lieu
        '// Gan du lieu vao arrCD tu C2 den dong cuoi cua cot C quet sang phai 7 cot
        arrCD = .Range("C2:C" & r).Resize(, 7).Value2
    End With                                            '//Ket thuc lam viec voi Sheet "DATA CD"
    With ThisWorkbook.Worksheets("DATA")                '// Lam viec voi Sheet "DATA"
        r = .Cells(.Rows.Count, "B").End(xlUp).Row      '// Xac dinh dong cuoi trong co B
        If r < 3 Then Exit Sub                          '// Thoat neu khong co du lieu
        '// Gan du lieu vao arrData tu B3 den dong cuoi cua cot B quet sang phai 5 cot
        arrData = .Range("B3:F" & r).Resize(, 5).Value2
        Set rData = .Range("B3") 'Gan B3 vao bien rData cho gon de xuong duoi khong phai viet lai ten sheet
    End With                                            '//Ket thuc lam viec voi Sheet "DATA"
    '//Khoi tao DIC
    Set dic = CreateObject("Scripting.Dictionary")
    '// Bat dau duyet tu vi tri dau tien den vi tri cuoi cung theo chieu thu 1 mang arrData
    '// tu tren xuong duoi tuong ung tren bang tinh tu B3:B3157 sheet Data
    For i = LBound(arrData, 1) To UBound(arrData, 1)
        '//Tim kiem theo 3 tieu chi : so oder / ma hang / tien do
        'sKey = arrData(i, 1) & "|" & arrData(i, 2) & arrData(i, 4)
        sKey = arrData(i, 1)                            '//Tim kiem theo 1 tieu chi : so oder
        '//Neu trong DIC chua ton tai sKey,gan sKey vao DIC va ghi nho vi tri thu i
        If Not dic.Exists(sKey) Then dic.Add sKey, i
    Next i                                              '// Ket thuc vong lap (dong cuoi cung)
    '// Bat dau duyet tu vi tri dau tien den vi tri cuoi cung theo chieu thu 1 mang arrData
    '// tu tren xuong duoi tuong ung tren bang tinh tu C2:C4233 sheet "DATA CD"
    For i = LBound(arrCD, 1) To UBound(arrCD, 1)
    '//Tim kiem theo 3 tieu chi : so oder / ma hang / tien do
        '//sKey = arrCD(i, 1) & "|" & arrCD(i, 2) & "|" & arrCD(i, 4)
        sKey = arrCD(i, 1) '//Tim kiem theo 1 tieu chi : so oder
        If dic.Exists(sKey) Then    '// Kiem tra xem sKey co ton tai trong DIC khong
        '/Cung giong voi viec kiem tra so oder trong "DATA CD" co ton tai trong sheet "DATA" khong
            r = dic.Item(sKey)                          '// Neu ton tai tra ve so dong so Oder tim kiem
            '// So sanh thoi gian hoan thanh trong "DATA CD" voi gia tri arrCD(i, 6): cot thu 6(CotH, tu C den H), dong r tim duoc o tren
            '// so voi thoi gian hoan thanh trong sheet "DATA" voi gia tri arrData(r, 5): cot thu 5(CotF, tu B den F), dong r tim duoc o tren
            If arrCD(i, 6) > arrData(r, 5) Then         '// Neu lon hon
                arrData(r, 5) = arrCD(i, 6)             '// Cap nhat thoi gian cua sheet "DATA CD"
                arrData(r, 4) = arrCD(i, 4)             '// Cap nhat tien do cua sheet "DATA CD"
            End If                                      '// Ket thuc If cua neu lon hon
        End If                                          '// Ket thuc If cua neu tim duoc so oder
    Next i                                              '// Ket thuc vong lap (dong cuoi cung)
    r = UBound(arrData, 1)                              '// So dong du lieu sheet DATA khong bao gom dong tieu de
    i = UBound(arrData, 2)                              '// So cot du lieu sheet DATA khong tu B den F
    rData.Resize(r, 2).NumberFormat = "@"               '// Dinh dang cot B,C dang Text tranh sai so oder & ma hang
    rData.Resize(r, i).Value = arrData                  '// Ghi ket qua xuong bang tinh
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Xài thử code này xem được không bạn
Mã: 
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")
For i = 1 To UBound(DataCD)
    Dic(CStr(DataCD(i, 1))) = i
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

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?
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Hoàng Nhật Phương đã viết:
Bạn thử lại:
Nhấp chuột vào đây để mở rộng...
Em mới phát hiện ra 1 điểm khác nhau giữa code của anh và của em.
Code của anh phân biệt chính xác chữ cái viết thường và viết hoa, code của em thì không
Tuy không ảnh hưởng đến chức năng nhưng nếu em muốn sửa code của anh để không phân biệt ký tự viết thường và hoa thì thế nào anh nhỉ?
 
Upvote 1
Haffaz Aladeen đã viết:
Em mới phát hiện ra 1 điểm khác nhau giữa code của anh và của em.
Code của anh phân biệt chính xác chữ cái viết thường và viết hoa, code của em thì không
Tuy không ảnh hưởng đến chức năng nhưng nếu em muốn sửa code của anh để không phân biệt ký tự viết thường và hoa thì thế nào anh nhỉ?
Nhấp chuột vào đây để mở rộng...
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:

Mã: 
Set dic = CreateObject("Scripting.Dictionary")
Dic.comparemode = vbTextCompare

P/s: cái này mới học lỏm được của bác @Ba Tê
 
Upvote 0
Cá ngừ F1 đã viết:
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?
Nhấp chuột vào đây để mở rộ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:

Cá ngừ F1 đã viết:
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:
Nhấp chuột vào đây để mở rộ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 ạ?
 
Upvote 0
Haffaz Aladeen đã viết:
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:


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 ạ?
Nhấp chuột vào đây để mở rộng...
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
Mã: 
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.
 
Upvote 0
Cá ngừ F1 đã viết:
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
Nhấp chuột vào đây để mở rộng...
Em cảm ơn anh nhiều ạ.
Cá ngừ F1 đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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!
 
Upvote 0
Haffaz Aladeen đã viết:
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!
Nhấp chuột vào đây để mở rộng...
Code của tôi đã chạy theo đúng ý bạn chưa vậy?
 
Upvote 0
Cá ngừ F1 đã viết:
Code của tôi đã chạy theo đúng ý bạn chưa vậy?
Nhấp chuột vào đây để mở rộng...
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:

Haffaz Aladeen đã viết:
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 ạ?
Nhấp chuột vào đây để mở rộng...
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 đính kèm

Upvote 0
Haffaz Aladeen đã viết:
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:


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ả ạ
Nhấp chuột vào đây để mở rộng...
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)
 
Upvote 0
Bạn thử File này xem đúng ý không nhé, click GPE
Mã: 
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
 

File đính kèm

Upvote 0
Haffaz Aladeen đã viết:
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:


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ả ạ
Nhấp chuột vào đây để mở rộng...
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 :)
PHP: 
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
 

File đính kèm

Upvote 0
vanthinh3101 đã viết:
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 :)
PHP: 
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
Nhấp chuột vào đây để mở rộng...
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ì
 
Upvote 0
Cá ngừ F1 đã viết:
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)
Nhấp chuột vào đây để mở rộ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ử).
Cá ngừ F1 đã viết:
Bạn thử File này xem đúng ý không nhé, click GPE
Nhấp chuột vào đây để mở rộng...
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 ạ.
vanthinh3101 đã viết:
File của bạn cứ có lỗi gì báo là không backup được.
Nhấp chuột vào đây để mở rộng...
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:

vanthinh3101 đã viết:
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 ạ :)
Nhấp chuột vào đây để mở rộng...
À 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 ạ
 
Lần chỉnh sửa cuối:
Upvote 0
Haffaz Aladeen đã viết:
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 ạ
Nhấp chuột vào đây để mở rộng...
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ỉ? ,,,,,,,
 
Upvote 0
Cá ngừ F1 đã viết:
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ỉ? ,,,,,,,
Nhấp chuột vào đây để mở rộng...
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 đó ạ
 
Upvote 0
Haffaz Aladeen đã viết:
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 đó ạ
Nhấp chuột vào đây để mở rộng...
Chạy sub Main để gọi lần lượt sub Update và LocTienDo
Mã: 
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
 
Lần chỉnh sửa cuối:
Upvote 0
HieuCD đã viết:
Chạy sub Main để gọi lần lượt sub Update và LocTienDo
Mã: 
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
Nhấp chuột vào đây để mở rộng...
Bác ơi , Bác chỉ con đoạn này với ạ:
Mã: 
...
      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ử. }}}}}
 
Upvote 0
@HieuCD cho em hỏi chút thầy ơi.
Mã: 
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ỉ.
 
Upvote 0
buiquangthuan đã viết:
@HieuCD cho em hỏi chút thầy ơi.
Mã: 
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ỉ.
Nhấp chuột vào đây để mở rộng...
Mình copy lệnh bị dư :) mắt mờ không thấy, đã chỉnh lại bài #34
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

P
Xin giúp sửa code VBA tổng hợp sản lượng theo format file FCS đổ từ hệ thống ERP. (2 người xem)
Trả lời
11
Đọc
132
DeTong
D
hongphuong1997
Cách tô màu một dòng theo chiều cao tùy ý (1 người xem)
Trả lời
4
Đọc
95
Excel my love_1
E
SA_DQ
  • Question Question
Bài tập VBA cho những người rỗi. . . đủ thứ! (2 người xem)
    • Yêu thích
Trả lời
3
Đọc
221
SA_DQ
SA_DQ
D
nhờ anh chị giải thích hàm hstack (2 người xem)
Trả lời
2
Đọc
54
dungpham01
D
L
Nhờ anh chị giúp giúp đỡ hàm ạ
    • Chấp nhận
Trả lời
12
Đọc
261
Phan Thế Hiệp
Phan Thế Hiệp
vuthaiha90
Lọc dữ liệu không trùng và trả kết quả về 1 dòng
Trả lời
6
Đọc
119
Duy Tùng 9x
Duy Tùng 9x
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
418
Đọc
51K
cudo38
cudo38
B
Copy textbox giữa 2 userform (2 người xem)
Trả lời
6
Đọc
141
Bảo_Anh_
B
L
  • Question Question
Khi chọn sheet 2, thì mặc định chọn ô A5
Trả lời
1
Đọc
59
vu_tuan_manh_linh
vu_tuan_manh_linh
H
Giúp mình ghép nhiều file thành một file.
Trả lời
2
Đọc
89
HUONGHCKT
H
ongke0711
  • Question Question
Tra cứu thông tin mã số thuế (cập nhật lại code cũ)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
11
Đọc
776
ongke0711
ongke0711
L
Nhờ anh chị giúp đỡ công thức hàm len
Trả lời
43
Đọc
477
linh34haiduong
L
H
Giúp đỡ Hàm tính ngày hết khấu hao, phân bổ?
Trả lời
2
Đọc
82
hitlecp
H
H
Đánh số thứ thự phiếu thu chi
Trả lời
29
Đọc
612
Phan Thế Hiệp
Phan Thế Hiệp
T
Nhờ anh chị xem giúp file bị lỗi gì mà chạy rất chậm/lag - File tính tiền nhà trọ
Trả lời
7
Đọc
212
A_Trung
A
V
Quản lý thu chi bằng excel (Tặng cho những ai cần đến)
    • Thích
Trả lời
65
Đọc
276K
Hoàng Tuấn 868
H
Nguyenkhang2404
giúp đỡ lọc dữ liệu nâng cao
Trả lời
23
Đọc
867
Nguyenkhang2404
Nguyenkhang2404
N
Chuyển dấu chấm thành dấu chấm phẩy trong dữ liệu (1 người xem)
Trả lời
6
Đọc
164
ngouyen1505
N
T
VBA LẤY THÔNG TIN TRÊN TỜ KHAI NHẬP KHẨU
Trả lời
7
Đọc
464
ThanhNgoc26100
T
H
  • Question Question
Xin giúp đỡ về tạo hàm excel với C# và excel-dna
Trả lời
5
Đọc
238
Tuanba1992
Tuanba1992
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom