Nhờ anh, chị, chú, bác viết giùm em VBA tìm dữ liệu qua nhiều sheet và trích dòng dữ liệu (2 người xem)

lagannini đã viết:

Em xin giải thích về mục đích tìm kiếm :
Các sheet A1,B1,C1 chứa dữ liệu kiểm tra hàng của rất nhiều nhân viên. Sheet "nhân viên cụ thể" chứa 1 phần dữ liệu từ sheet "A1". Em tách ra để dễ nhìn
tại sheet "nhân viên cụ thể" tìm từng giá trị ở cột E (số seri) trong tất cả các sheet khác ( trừ sheet "nhân viên cụ thể" và "kết quả"). Nếu tìm thấy nhân viên khác có cùng số seri thì ghi lại dòng dữ liệu tương ứng vào sheet "kết quả". Cụ thể hơn mời anh chị xem tệp đính kèm ạ. Mong được sự giúp đỡ. Em xin cảm ơn mọi người đã xem bài viết.

Nhấp chuột vào đây để mở rộng...

HUONGHCKT đã viết:

Tham khảo code trong file đính kèm
Tôi đã sửa lại tên 2 sh nhân viên cụ thể thành NVCT và sh kết quả thành KetQua.
Nhấn nút RunCode ở sheet KetQua để được kết quả.

Nhấp chuột vào đây để mở rộng...

SA_DQ đã viết:

@Tác giả bài đăng: Ở trang 'KetQua' nên có cấu trúc tương tự như vầy
:
View attachment 310277

Nhấp chuột vào đây để mở rộng...

lagannini đã viết:

Xin cảm ơn Chị đã dành thời gian giải đáp cho em. Giờ em gặp 1 vấn đề là code không thể chạy trên hệ điều hành MacOS, vì lí do bảo mật nên cty em chỉ cấp macbook cho nhân viên dùng. Em xin phép được nhờ Chị chỉnh code giúp em ạ. Và nhờ Chị thêm 1 điều kiện trong bài đó là những số seri chỉ có 1 nhân viên kiểm tra thì không cần hiện thị trong sheet "KetQua", chỉ hiện thị những seri có từ 2 nhân viên kiểm tra . E xin cảm ơn ạ. View attachment 310280

Bài đã được tự động gộp: 11/11/25

Dạ em xin cảm ơn góp ý của Anh. Em sẽ xem xét điều chỉnh lại sau ạ.

Nhấp chuột vào đây để mở rộng...

Sub TimKiem()
Dim i&, j&, Lr&, t&, k&, R&, C&
Dim Arr(), KQ(), DL(), S
Dim Dic As Object, Key
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("NVCT")
Lr = Sh.Range("E100000").End(xlUp).Row
Set Dic = CreateObject("Scripting.Dictionary")
ReDim DL(1 To 100000, 1 To 100)
For Each Ws In Worksheets
    If Ws.Name <> "NVCT?" And Ws.Name <> "KetQua" Then
        Lr = Ws.Range("E100000").End(xlUp).Row
        Arr = Ws.Range("A2:K" & Lr).Value
        R = UBound(Arr): C = UBound(Arr, 2)
            For i = 1 To R
                d = d + 1
                For j = 1 To UBound(Arr, 2)
                    DL(d, j) = Arr(i, j)
                Next j
                    Key = Arr(i, 5)
                If Not Dic.Exists(Key) Then Dic(Key) = d Else Dic(Key) = Dic(Key) & "," & d
            Next i
    End If
Next Ws
ReDim KQ(1 To UBound(DL), 1 To 4)
For i = 2 To Lr
    Key = Sh.Range("E" & i)
    If Dic.Exists(Key) Then
        If InStr(Dic(Key), ",") Then
            S = Split(Dic(Key), ",")
            For j = LBound(S) To UBound(S)
                k = k + 1
                If j = 0 Then
                    KQ(k, 1) = Key
                Else
                    KQ(k, 1) = Empty
                End If
                    KQ(k, 2) = DL(S(j), 3)
                    If Trim(DL(S(j), 10)) = "trái" Then C = 3 Else C = 4
                    KQ(k, C) = DL(S(j), 10) & " " & DL(S(j), 6)
            Next j
'        Else
'            k = k + 1
'            KQ(k, 2) = DL(Dic(Key), 3)
'            If Trim(DL(Dic(Key), 10)) = "trái" Then C = 3 Else C = 4
'            KQ(k, C) = DL(Dic(Key), 10) & " " & DL(Dic(Key), 6)
'        End If
    End If
Next i
If k Then
   With Sheets("KetQua")
        .Range("G2:D1000000").ClearContents
        .Range("G2").Resize(k, 4) = KQ
        MsgBox "Xong"
    End With
Else
    MsgBox " Không tìm thây du liêu "
End If
Set Dic = Nothing

End Sub

HUONGHCKT đã viết:

Vậy thì khó rồi, tôi không có macOS để thử. Còn vấn đề chỉ hiện mã seri có trên 2 NV thì để tôi sửa.
thay vì xóa bỏ code cũ bạn thêm 1 module mới và copy /patse đoạn code vào vào chạy thử

Mã: Sao chép.

Sub TimKiem()
...
Set Dic = CreateObject("Scripting.Dictionary")
...

Nhấp chuột vào đây để mở rộng...

ongke0711 đã viết:

VBA của Office trên máy Mac nó rất hạn chế thư viện, không hỗ trợ:
- ActiveX Controls
- Các thư viện API của Windows.
Do đó thư viện "Scripting Dictionary" là không chạy được rồi. Bạn thử đổi qua dùng Collection xem, nó là thư viện của VBA.


View attachment 310283

Nhấp chuột vào đây để mở rộng...

HUONGHCKT đã viết:

Với sự hỗ trợ của Copilot tôi đã hoàn thành mặc dù không hiểu hết bản chất của Collection.

Mã: Sao chép.

Sub Tim_CollectionNested()
    Dim i&, j&, Lr&, k&, R&, C&, d
    Dim Arr(), KQ(), DL()
    Dim DicKeys As Collection, DicValues As Collection
    Dim Key As Variant, SubCol As Collection
    Dim Sh As Worksheet, Ws As Worksheet

    Set Sh = Sheets("NVCT")
    Lr = Sh.Range("E100000").End(xlUp).Row

    Set DicKeys = New Collection
    Set DicValues = New Collection
    ReDim DL(1 To 100000, 1 To 100)

    ' T?ng h?p d? li?u t? các sheet
    For Each Ws In Worksheets
        If Ws.Name <> "NVCT?" And Ws.Name <> "KetQua" Then
            Lr = Ws.Range("E100000").End(xlUp).Row
            Arr = Ws.Range("A2:K" & Lr).Value
            R = UBound(Arr): C = UBound(Arr, 2)
            For i = 1 To R
                d = d + 1
                For j = 1 To C
                    DL(d, j) = Arr(i, j)
                Next j
                Key = Arr(i, 5)
                Dim Found As Boolean: Found = False
                For j = 1 To DicKeys.Count
                    If DicKeys(j) = Key Then
                        DicValues(j).Add d
                        Found = True
                        Exit For
                    End If
                Next j
                If Not Found Then
                    DicKeys.Add Key
                    Set SubCol = New Collection
                    SubCol.Add d
                    DicValues.Add SubCol
                End If
            Next i
        End If
    Next Ws

    ReDim KQ(1 To d, 1 To 4)
    For i = 2 To Sh.Range("E100000").End(xlUp).Row
        Key = Sh.Range("E" & i).Value
        For j = 1 To DicKeys.Count
            If DicKeys(j) = Key Then
                Set SubCol = DicValues(j)
                For Each d In SubCol
                    k = k + 1
                    If SubCol(1) = d Then
                        KQ(k, 1) = Key
                    Else
                        KQ(k, 1) = Empty
                    End If
                    KQ(k, 2) = DL(d, 3)
                    If Trim(DL(d, 10)) = "trái" Then C = 3 Else C = 4
                    KQ(k, C) = DL(d, 10) & " " & DL(d, 6)
                Next d
                Exit For
            End If
        Next j
    Next i

    If k Then
        With Sheets("KetQua")
            .Range("A2:D1000000").ClearContents
            .Range("A2").Resize(k, 4).Value = KQ
            MsgBox "Xong"
        End With
    Else
        MsgBox "Không tìm th?y d? li?u"
    End If
End Sub

Nhấp chuột vào đây để mở rộng...