Thay thế công thức tìm kiếm theo nhiều điều kiện bằng VBA

[binh.eptc]

Tôi có file excel này, sử dụng công thức excel thì đã ra kết quả như mong muốn, nhưng file chạy nặng và nếu dữ liệu cần lấy nhiều hơn nữa thì chạy rất chậm. nhờ các cao nhân viết giùm đoạn code VBA thay thế công thức trong file đính kèm. Xin cảm ơn.
Trân trọng./.

Lưu ý: Lần sau post bài mới thì tên tiêu đề cần sát với nội dung câu hỏi, trong bài đừng nửa tây nửa ta (lần này tôi sửa lại cho bạn - Mod: Cá ngừ F1)

 

[Maika8008]

Tán thành cách làm của mod Cá ngừ F1.

 

[binh.eptc]

Tôi có file excel này, sử dụng công thức excel thì đã ra kết quả như mong muốn, nhưng file chạy nặng và nếu dữ liệu cần lấy nhiều hơn nữa thì chạy rất chậm. nhờ các cao nhân viết giùm đoạn code VBA thay thế công thức trong file đính kèm. Xin cảm ơn.
Trân trọng./.

Lưu ý: Lần sau post bài mới thì tên tiêu đề cần sát với nội dung câu hỏi, trong bài đừng nửa tây nửa ta (lần này tôi sửa lại cho bạn - Mod: Cá ngừ F1)

cảm ơn Mod: Cá ngừ, tôi không thạo lắm nên thông cảm.

 

[Cá ngừ F1]

Bạn thử Code này

Sub TimKiem()
On Error Resume Next
Dim sArr(), i&, k&, Giao(), Dic As Object, KQ1(), Nhan(), KQ2(), Col
sArr = Sheet1.Range("A13", Sheet1.Range("A" & Rows.Count).End(3)).Resize(, 53).Value
Giao = Sheet2.Range("A3", Sheet2.Range("A" & Rows.Count).End(3)).Resize(, 3).Value
Nhan = Sheet2.Range("BB3", Sheet2.Range("BB" & Rows.Count).End(3)).Resize(, 3).Value
ReDim KQ1(1 To UBound(Giao), 1 To 48)
ReDim KQ2(1 To UBound(Nhan), 1 To 48)
Col = Array(0, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48)
Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = vbTextCompare
For i = 1 To UBound(sArr)
    Dic(sArr(i, 1) & sArr(i, 4) & sArr(i, 5)) = i
Next
For i = 1 To UBound(Giao)
    For k = 1 To 48
        KQ1(i, k) = sArr(Dic.Item(Giao(i, 1) & Giao(i, 2) & Giao(i, 3)), Col(k))
    Next
Next
For i = 1 To UBound(Nhan)
    For k = 1 To 48
        KQ2(i, k) = sArr(Dic.Item(Nhan(i, 1) & Nhan(i, 2) & Nhan(i, 3)), Col(k))
    Next
Next
Sheet2.Range("D3").Resize(i - 1, 48) = KQ1
Sheet2.Range("BE3").Resize(i - 1, 48) = KQ2
End Sub

 

[binh.eptc]

Bạn thử Code này

Sub TimKiem()
On Error Resume Next
Dim sArr(), i&, k&, Giao(), Dic As Object, KQ1(), Nhan(), KQ2(), Col
sArr = Sheet1.Range("A13", Sheet1.Range("A" & Rows.Count).End(3)).Resize(, 53).Value
Giao = Sheet2.Range("A3", Sheet2.Range("A" & Rows.Count).End(3)).Resize(, 3).Value
Nhan = Sheet2.Range("BB3", Sheet2.Range("BB" & Rows.Count).End(3)).Resize(, 3).Value
ReDim KQ1(1 To UBound(Giao), 1 To 48)
ReDim KQ2(1 To UBound(Nhan), 1 To 48)
Col = Array(0, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48)
Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = vbTextCompare
For i = 1 To UBound(sArr)
    Dic(sArr(i, 1) & sArr(i, 4) & sArr(i, 5)) = i
Next
For i = 1 To UBound(Giao)
    For k = 1 To 48
        KQ1(i, k) = sArr(Dic.Item(Giao(i, 1) & Giao(i, 2) & Giao(i, 3)), Col(k))
    Next
Next
For i = 1 To UBound(Nhan)
    For k = 1 To 48
        KQ2(i, k) = sArr(Dic.Item(Nhan(i, 1) & Nhan(i, 2) & Nhan(i, 3)), Col(k))
    Next
Next
Sheet2.Range("D3").Resize(i - 1, 48) = KQ1
Sheet2.Range("BE3").Resize(i - 1, 48) = KQ2
End Sub

Đúng như mong đợi, một lần nữa xin cảm ơn Mod: cá Ngừ F1