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

Liên hệ QC
N

ngtchung

Thành viên mới
Tham gia
11/10/08
Bài viết
48
Được thích
19
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.
 

File đính kèm

  • TP_Monitor_ALl.xlsb
    157.8 KB · Đọc: 20
ngtchung đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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.
 
3ii đã viết:
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.
Nhấp chuột vào đây để mở rộng...
Tư vấn rất hay, bác viết code luôn cho bạn ấy đi cho gọn.
 
Hoàng Tuấn 868 đã viết:
Bác viết đi, càng nhiều hướng anh em càng tham khảo thêm kinh nghiệm.
Nhấp chuột vào đây để mở rộng...

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:

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
 
3ii đã viết:
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:

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
Nhấp chuột vào đây để mở rộng...
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.
 
3ii đã viết:
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:

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
Nhấp chuột vào đây để mở rộng...
Viết tuyệt vời thế còn gì.
 
ngtchung đã viết:
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.
Nhấp chuột vào đây để mở rộng...
Thử thêm 1 cách khác coi thế nào
Mã: 
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
 
BuiQuangThuan đã viết:
Thử thêm 1 cách khác coi thế nào
Mã: 
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
Nhấp chuột vào đây để mở rộng...
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 à.
 
3ii đã viết:
ý 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 ạ
Nhấp chuột vào đây để mở rộng...
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 đủ.
 
3ii đã viết:
ý 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 ạ
Nhấp chuột vào đây để mở rộng...
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). :D
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2 3 4
Trả lời
60
Đọc
872
CHAOQUAY
C
S
Sao excel lại biến dữ liệu thành dữ liệu nhiều các con số?
Trả lời
6
Đọc
51
syquyen1987
S
C
Hàm Textjoin nối chuỗi có định dạng ngày tháng
Trả lời
10
Đọc
405
polyvietnam
polyvietnam
T
Nhờ giúp tính tổng ô đã Merge
Trả lời
0
Đọc
12
thuytrangbp28
T
emlat3
Đặt màu xen kẽ các dòng theo ký tự
Trả lời
5
Đọc
121
VetMini
V
Xem thêm…

Facebook

Giaiphapexcel.com

Group

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

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom