Trợ giúp dùng mảng như vlooup trong VBA

[ngtchung]

Kính chào các anh em trong diễn đàn.
Hiện tại mình đang quản lý 1 file tổng hợp data từ 2 file của 2 block A và B hàng ngày ( số lượng trên 8000 dòng). Để cho bớt dùng công thức thì mình có dùng VBA ( dạng chạy vòng lặp for ) nên chạy khá lâu do số dòng tăng dần. Thì mình có đọc trên diễn đàn dùng Dic và mảng thì tốc độ rất nhanh từ các anh em. Sau thời gian tự mò mầm học vẹt thì cũng chạy và lấy data được, nhưng mình có vướng mắc là khỉ đổ data về cùng 1 cột trên file của mình khi chạy lấy data bên block A thì mất data bên block B ( hiện blank) và ngược lại lấy B thì mất bên A.
Kính mong các anh chị trên diễn đàn tư vẫn thêm và có cách nào hiệu quả hơn và tốc độ cao hơn.
Chi tiết file đính kèm.
Cơ câu file :
1 sheet Monitor gồm 1 cột tham chiếu chung là Testpack và lấy data theo cột này.
2 sheet Block A và Block, có cột Testpack tham chiếu chung và được nhập hàng ngày.
Sheet Monitor sẽ lấy data từ 2 sheet block A và block B đổ về cùng các cột G, H,K,L,( tô vàng)
Trân trọng cảm ơn.

 

[Ngày mai trời lại sáng]

Kính chào các anh em trong diễn đàn.
Hiện tại mình đang quản lý 1 file tổng hợp data từ 2 file của 2 block A và B hàng ngày ( số lượng trên 8000 dòng). Để cho bớt dùng công thức thì mình có dùng VBA ( dạng chạy vòng lặp for ) nên chạy khá lâu do số dòng tăng dần. Thì mình có đọc trên diễn đàn dùng Dic và mảng thì tốc độ rất nhanh từ các anh em. Sau thời gian tự mò mầm học vẹt thì cũng chạy và lấy data được, nhưng mình có vướng mắc là khỉ đổ data về cùng 1 cột trên file của mình khi chạy lấy data bên block A thì mất data bên block B ( hiện blank) và ngược lại lấy B thì mất bên A.
Kính mong các anh chị trên diễn đàn tư vẫn thêm và có cách nào hiệu quả hơn và tốc độ cao hơn.
Chi tiết file đính kèm.
Cơ câu file :
1 sheet Monitor gồm 1 cột tham chiếu chung là Testpack và lấy data theo cột này.
2 sheet Block A và Block, có cột Testpack tham chiếu chung và được nhập hàng ngày.
Sheet Monitor sẽ lấy data từ 2 sheet block A và block B đổ về cùng các cột G, H,K,L,( tô vàng)
Trân trọng cảm ơn.

Theo ý kiến của mình thì nên gộp chung 2 chức năng "Get data Block A" và "Get data Block B" vào chung một thủ tục và dùng một mảng kết quả, có thể duyệt từng sheet chi tiết để xử lý nếu thỏa điều kiện thì gán vào mảng kết quả rồi đưa xuống sheet một lần.

 

[Hoàng Tuấn 868]

Theo ý kiến của mình thì nên gộp chung 2 chức năng "Get data Block A" và "Get data Block B" vào chung một thủ tục và dùng một mảng kết quả, có thể duyệt từng sheet chi tiết để xử lý nếu thỏa điều kiện thì gán vào mảng kết quả rồi đưa xuống sheet một lần.

Tư vấn rất hay, bác viết code luôn cho bạn ấy đi cho gọn.

 

[Ngày mai trời lại sáng]

Tư vấn rất hay, bác viết code luôn cho bạn ấy đi cho gọn.

À thì em cũng định viết nhưng mà biết đâu có thể còn có nhiều hướng khác gọn hơn bác ạ.

 

[Hoàng Tuấn 868]

À thì em cũng định viết nhưng mà biết đâu có thể còn có nhiều hướng khác gọn hơn bác ạ.

Bác viết đi, càng nhiều hướng anh em càng tham khảo thêm kinh nghiệm.

 

[Ngày mai trời lại sáng]

Bác viết đi, càng nhiều hướng anh em càng tham khảo thêm kinh nghiệm.

Thôi thì em lỡ phát biểu rồi , cũng trùm chăn đi ngủ rồi nhưng nghĩ ngày mai có thể không xem được nên cố dậy để viết vậy.
Bác tham khảo và góp ý để em có thêm kinh nghiệm:

Sub tim_block()

    Dim dict As Object, block As Variant, ketqua As Variant
    Dim strTestPack As String, i As Long, k As Long, lastRow As Long
    Dim shBlock As Worksheet, shMonitor As Worksheet
  
    Set shMonitor = ThisWorkbook.Worksheets("TP MONITOR")
    With shMonitor
        lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
        If (lastRow < 2) Then
            MsgBox "Khong co du lieu cot: TestPack", vbCritical + vbOKOnly
            Exit Sub
        End If
        ketqua = .Range("D2:X" & lastRow).Value
    End With
  
    Set dict = CreateObject("Scripting.Dictionary")
    For i = LBound(ketqua, 1) To UBound(ketqua, 1)
        strTestPack = "TestPack:" & ketqua(i, 1)
        If Not dict.Exists(strTestPack) Then dict.Add strTestPack, i
    Next i
  
    For Each shBlock In ThisWorkbook.Worksheets
        If (shBlock.Name = "BasicB") Or (shBlock.Name = "Cons Blk A") Then
            With shBlock
                lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
                If (lastRow > 2) Then
                    block = .Range("D2:P" & lastRow).Value
                    For i = LBound(block, 1) To UBound(block, 1)
                        strTestPack = "TestPack:" & block(i, 1)
                        If dict.Exists(strTestPack) Then
                            k = dict.Item(strTestPack)
                            If (shBlock.Name = "Cons Blk A") Then
                                ketqua(k, 8) = block(i, 2)      'ENG REVIEW
                                ketqua(k, 9) = block(i, 3)      'Returned
                                ketqua(k, 11) = block(i, 2)     'ENG REVIEW
                                ketqua(k, 13) = block(i, 3)     'Returned
                                ketqua(k, 21) = block(i, 4)     'TESTED
                            Else
                                ketqua(k, 4) = block(i, 4)      'Sub-Con Submit TP Basic [Name]
                                ketqua(k, 5) = block(i, 6)      'Sub-Con Submit TP Basic [Date]
                                ketqua(k, 8) = block(i, 9)      'TP Under Review by FE
                                ketqua(k, 11) = block(i, 10)    'TP Under Review by EP
                                ketqua(k, 13) = block(i, 11)    'TP BASIC Returned to S/C
                            End If
                        End If
                    Next i
                End If
            End With
        End If
    Next shBlock
    shMonitor.Range("D2").Resize(UBound(ketqua, 1), UBound(ketqua, 2)).Value = ketqua
    MsgBox "Xong!", vbInformation + vbOKOnly
End Sub

 

[ngtchung]

Thôi thì em lỡ phát biểu rồi , cũng trùm chăn đi ngủ rồi nhưng nghĩ ngày mai có thể không xem được nên cố dậy để viết vậy.
Bác tham khảo và góp ý để em có thêm kinh nghiệm:

Sub tim_block()

    Dim dict As Object, block As Variant, ketqua As Variant
    Dim strTestPack As String, i As Long, k As Long, lastRow As Long
    Dim shBlock As Worksheet, shMonitor As Worksheet
 
    Set shMonitor = ThisWorkbook.Worksheets("TP MONITOR")
    With shMonitor
        lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
        If (lastRow < 2) Then
            MsgBox "Khong co du lieu cot: TestPack", vbCritical + vbOKOnly
            Exit Sub
        End If
        ketqua = .Range("D2:X" & lastRow).Value
    End With
 
    Set dict = CreateObject("Scripting.Dictionary")
    For i = LBound(ketqua, 1) To UBound(ketqua, 1)
        strTestPack = "TestPack:" & ketqua(i, 1)
        If Not dict.Exists(strTestPack) Then dict.Add strTestPack, i
    Next i
 
    For Each shBlock In ThisWorkbook.Worksheets
        If (shBlock.Name = "BasicB") Or (shBlock.Name = "Cons Blk A") Then
            With shBlock
                lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
                If (lastRow > 2) Then
                    block = .Range("D2:P" & lastRow).Value
                    For i = LBound(block, 1) To UBound(block, 1)
                        strTestPack = "TestPack:" & block(i, 1)
                        If dict.Exists(strTestPack) Then
                            k = dict.Item(strTestPack)
                            If (shBlock.Name = "Cons Blk A") Then
                                ketqua(k, 8) = block(i, 2)      'ENG REVIEW
                                ketqua(k, 9) = block(i, 3)      'Returned
                                ketqua(k, 11) = block(i, 2)     'ENG REVIEW
                                ketqua(k, 13) = block(i, 3)     'Returned
                                ketqua(k, 21) = block(i, 4)     'TESTED
                            Else
                                ketqua(k, 4) = block(i, 4)      'Sub-Con Submit TP Basic [Name]
                                ketqua(k, 5) = block(i, 6)      'Sub-Con Submit TP Basic [Date]
                                ketqua(k, 8) = block(i, 9)      'TP Under Review by FE
                                ketqua(k, 11) = block(i, 10)    'TP Under Review by EP
                                ketqua(k, 13) = block(i, 11)    'TP BASIC Returned to S/C
                            End If
                        End If
                    Next i
                End If
            End With
        End If
    Next shBlock
    shMonitor.Range("D2").Resize(UBound(ketqua, 1), UBound(ketqua, 2)).Value = ketqua
    MsgBox "Xong!", vbInformation + vbOKOnly
End Sub

Wow, thật là quá khủng khiếp, anh giỏi quá và viết code quá có tâm. Mình chỉnh lại thông tin cột là cho khớp nữa là ok. file chạy perfect luôn anh.
Cám ơn anh đã support và các anh em trong diễn đàn.
Sẽ tiếp tục mò mẫm để hiểu thêm các code của anh.
Trân trọng cảm ơn.

 

[Hoàng Tuấn 868]

Thôi thì em lỡ phát biểu rồi , cũng trùm chăn đi ngủ rồi nhưng nghĩ ngày mai có thể không xem được nên cố dậy để viết vậy.
Bác tham khảo và góp ý để em có thêm kinh nghiệm:

Sub tim_block()

    Dim dict As Object, block As Variant, ketqua As Variant
    Dim strTestPack As String, i As Long, k As Long, lastRow As Long
    Dim shBlock As Worksheet, shMonitor As Worksheet
 
    Set shMonitor = ThisWorkbook.Worksheets("TP MONITOR")
    With shMonitor
        lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
        If (lastRow < 2) Then
            MsgBox "Khong co du lieu cot: TestPack", vbCritical + vbOKOnly
            Exit Sub
        End If
        ketqua = .Range("D2:X" & lastRow).Value
    End With
 
    Set dict = CreateObject("Scripting.Dictionary")
    For i = LBound(ketqua, 1) To UBound(ketqua, 1)
        strTestPack = "TestPack:" & ketqua(i, 1)
        If Not dict.Exists(strTestPack) Then dict.Add strTestPack, i
    Next i
 
    For Each shBlock In ThisWorkbook.Worksheets
        If (shBlock.Name = "BasicB") Or (shBlock.Name = "Cons Blk A") Then
            With shBlock
                lastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
                If (lastRow > 2) Then
                    block = .Range("D2:P" & lastRow).Value
                    For i = LBound(block, 1) To UBound(block, 1)
                        strTestPack = "TestPack:" & block(i, 1)
                        If dict.Exists(strTestPack) Then
                            k = dict.Item(strTestPack)
                            If (shBlock.Name = "Cons Blk A") Then
                                ketqua(k, 8) = block(i, 2)      'ENG REVIEW
                                ketqua(k, 9) = block(i, 3)      'Returned
                                ketqua(k, 11) = block(i, 2)     'ENG REVIEW
                                ketqua(k, 13) = block(i, 3)     'Returned
                                ketqua(k, 21) = block(i, 4)     'TESTED
                            Else
                                ketqua(k, 4) = block(i, 4)      'Sub-Con Submit TP Basic [Name]
                                ketqua(k, 5) = block(i, 6)      'Sub-Con Submit TP Basic [Date]
                                ketqua(k, 8) = block(i, 9)      'TP Under Review by FE
                                ketqua(k, 11) = block(i, 10)    'TP Under Review by EP
                                ketqua(k, 13) = block(i, 11)    'TP BASIC Returned to S/C
                            End If
                        End If
                    Next i
                End If
            End With
        End If
    Next shBlock
    shMonitor.Range("D2").Resize(UBound(ketqua, 1), UBound(ketqua, 2)).Value = ketqua
    MsgBox "Xong!", vbInformation + vbOKOnly
End Sub

Viết tuyệt vời thế còn gì.

 

[BuiQuangThuan]

Kính mong các anh chị trên diễn đàn tư vẫn thêm và có cách nào hiệu quả hơn và tốc độ cao hơn.

Thử thêm 1 cách khác coi thế nào

Option Explicit
Sub ABC()
Dim Dic As Object, Res(), Arr(0 To 1), n%, i&, Sh, sRow&, sCol&, sArr(), iRow&, iKey
Dim j&
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("TP MONITOR")
    iRow = .Range("D" & Rows.Count).End(3).Row
    If iRow < 1 Then MsgBox "Ko co du lieu": Exit Sub
    Res = .Range("A2:AM" & iRow).Value
End With
For i = 1 To UBound(Res, 1)
    If Res(i, 4) <> Empty Then
        Dic.Item(Res(i, 4)) = i
    End If
Next
Sh = Array("BasicB", "Cons Blk A")
For n = 0 To 1
    With Sheets(Sh(n))
        sRow = .Range("D" & Rows.Count).End(xlUp).Row
        sCol = .Range("AAA1").End(xlToLeft).Column
        Arr(n) = .Range("A1", .Cells(sRow, sCol)).Value
    End With
    sArr = Arr(n)
    For i = 2 To UBound(sArr, 1)
        If sArr(i, 4) <> Empty Then
            iKey = sArr(i, 4)
            j = Dic.Item(iKey)
            If j > 0 Then
                If n = 0 Then
                    Res(j, 6) = "B"
                    Res(j, 7) = sArr(i, 7)
                    Res(j, 8) = sArr(i, 9)
                    Res(j, 11) = sArr(i, 12)
                    Res(j, 12) = sArr(i, 13)
                    Res(j, 13) = sArr(i, 14)
                    Res(j, 14) = sArr(i, 15)
                    Res(j, 16) = sArr(i, 16)
                Else
                    Res(j, 6) = "A"
                    Res(j, 11) = sArr(i, 5)
                    Res(j, 12) = sArr(i, 6)
                    Res(j, 16) = sArr(i, 5)
                    Res(j, 24) = sArr(i, 7)
                End If
            End If
        End If
    Next
Next n
Sheets("TP MONITOR").Range("A2").Resize(UBound(Res, 1), UBound(Res, 2)).Value = Res
End Sub

 

[Ngày mai trời lại sáng]

Thử thêm 1 cách khác coi thế nào

Option Explicit
Sub ABC()
Dim Dic As Object, Res(), Arr(0 To 1), n%, i&, Sh, sRow&, sCol&, sArr(), iRow&, iKey
Dim j&
Set Dic = CreateObject("Scripting.dictionary")
With Sheets("TP MONITOR")
    iRow = .Range("D" & Rows.Count).End(3).Row
    If iRow < 1 Then MsgBox "Ko co du lieu": Exit Sub
    Res = .Range("A2:AM" & iRow).Value
End With
For i = 1 To UBound(Res, 1)
    If Res(i, 4) <> Empty Then
        Dic.Item(Res(i, 4)) = i
    End If
Next
Sh = Array("BasicB", "Cons Blk A")
For n = 0 To 1
    With Sheets(Sh(n))
        sRow = .Range("D" & Rows.Count).End(xlUp).Row
        sCol = .Range("AAA1").End(xlToLeft).Column
        Arr(n) = .Range("A1", .Cells(sRow, sCol)).Value
    End With
    sArr = Arr(n)
    For i = 2 To UBound(sArr, 1)
        If sArr(i, 4) <> Empty Then
            iKey = sArr(i, 4)
            j = Dic.Item(iKey)
            If j > 0 Then
                If n = 0 Then
                    Res(j, 6) = "B"
                    Res(j, 7) = sArr(i, 7)
                    Res(j, 8) = sArr(i, 9)
                    Res(j, 11) = sArr(i, 12)
                    Res(j, 12) = sArr(i, 13)
                    Res(j, 13) = sArr(i, 14)
                    Res(j, 14) = sArr(i, 15)
                    Res(j, 16) = sArr(i, 16)
                Else
                    Res(j, 6) = "A"
                    Res(j, 11) = sArr(i, 5)
                    Res(j, 12) = sArr(i, 6)
                    Res(j, 16) = sArr(i, 5)
                    Res(j, 24) = sArr(i, 7)
                End If
            End If
        End If
    Next
Next n
Sheets("TP MONITOR").Range("A2").Resize(UBound(Res, 1), UBound(Res, 2)).Value = Res
End Sub

Thêm cái bắt lỗi nếu không tìm thấy tên sheet nữa là tuyệt bác à.

 

[BuiQuangThuan]

Thêm cái bắt lỗi nếu không tìm thấy tên sheet nữa là tuyệt bác à.

Tên sheet được khai báo ngay từ lúc đầu rồi mà anh

 

[Ngày mai trời lại sáng]

Tên sheet được khai báo ngay từ lúc đầu rồi mà anh

ý em là nếu tên sheet bị thay đổi mà trong code nó không tìm thấy thì sẽ bị lỗi bác ạ

 

[VetMini]

ý em là nếu tên sheet bị thay đổi mà trong code nó không tìm thấy thì sẽ bị lỗi bác ạ

Lúc đó bút vẫn chưa sa, gà chưa chết. Thấy lỗi thì sửa lại, không sao cả.
Loại làm việc "mì ăn liền" này chỉ ra kết quả là "perfect [sic]" rồi, cần chi phải đầy đủ.

 

[batman1]

ý em là nếu tên sheet bị thay đổi mà trong code nó không tìm thấy thì sẽ bị lỗi bác ạ

Thực ra lỗi run-time không đáng sợ vì nó luôn ý thức cho mình là có lỗi, mình sẽ dò tìm và sửa được. Chỉ sợ những code không có lỗi nhưng kết quả không như mong đợi, vd. sai về thuật toán. Lúc đó người dùng không ý thức được là có gì đó không ổn. Tưởng mọi chuyện vẫn cứ tốt đẹp nên rung đùi, hài lòng, yên tâm tận hưởng mọi cái đẹp của cuộc sống (vd. cái đẹp đang ở trên cái đùi rung kia).