Xin hướng dẫn xây dựng công thức truy xuất thông tin nhanh dùm cho việc truy vết thông tin (2 người xem)

Xuanhuy175995 · 18/8/21

Em xin mô tả như sau: Công ty em mỗi ngày có 200 người tham gia sản xuất và mỗi người sẽ khai báo vào form có thông tin( thường xuyên tiếp xúc, ít tiếp xúc, không tiếp xúc) đối với 199 người . em tạo form google nên hằng ngày được 1 file thống kê ( file đính kèm bên dưới). Khi có trường hợp nào nghi ngờ thì căn cứ vào các file đó để truy vết tuy nhiên có một khó khăn là vd 1F1 em tìm 20 F2( đk lọc là thường xuyên tiếp xúc) và từ F2 tìm tiếp những người thường xuyên tiếp xúc trong bao nhiêu ngày - đơn giản là chỉ cần đặt lệnh lọc nhưng rất mất thời mà truy vế thì cần nhanh. Nay em muốn nhờ sự giúp đỡ của mọi người rành về excel xây dựng 1 cách tìm kiếm liên kết có điều kiện là " thường xuyên tiếp xúc" Chỉ cần từ F1 truy xuống F3 bằng 1 dòng tìm kiếm thể hiện ra hết mọi thứ ( hiện tên của F2 và F3 1 lượt)

ongke0711 · 18/8/21

Xuanhuy175995 đã viết:
Chỉ cần từ F1 truy xuống F3 bằng 1 dòng tìm kiếm thể hiện ra hết mọi thứ ( hiện tên của F2 và F3 1 lượt)

Dữ liệu trong file Excel có phải dữ liệu thô (gốc) hay chưa? Tôi nhìn giống dữ liệu đã pivot để báo cáo. Nếu có thì bạn gửi file dữ liệu thô ban đầu của hệ thống chưa qua xử lý xem thử.

Xuanhuy175995 · 18/8/21

ongke0711 đã viết:
Dữ liệu trong file Excel có phải dữ liệu thô (gốc) hay chưa? Tôi nhìn giống dữ liệu đã pivot để báo cáo. Nếu có thì bạn gửi file dữ liệu thô ban đầu của hệ thống chưa qua xử lý xem thử.

à không là dữ liệu gốc mình tải từ google form về luôn, chỉ có điều chỉnh đổi ngược cột và hàng để cho dễ lọc hơn thôi

ongke0711 · 20/8/21

Xuanhuy175995 đã viết:
1 cách tìm kiếm liên kết có điều kiện là " thường xuyên tiếp xúc" Chỉ cần từ F1 truy xuống F3 bằng 1 dòng tìm kiếm thể hiện ra hết mọi thứ ( hiện tên của F2 và F3 1 lượt)

Tôi chỉ xử lý được theo dạng này thôi. Code xử lý lại dữ liệu phù hợp cho việc dùng Pivot.

Mã:

Sub TongHop_C1()
    
    Dim arrData() As Variant, arrF1() As Variant, arrF2() As Variant, arrF3() As Variant
    Dim dicF1 As Dictionary, dicF2 As Dictionary, dicF3 As Dictionary
    Dim tenNV$, dk$, RowNum&, i&, j&, k&, n&
    
    Set dicF1 = New Dictionary
    Set dicF2 = New Dictionary
    Set dicF3 = New Dictionary
    
    arrData = Sheet1.UsedRange.Value
    tenNV = Sheet2.Range("B3")
    dk = Sheet2.Range("B4")
    
    Worksheets("BaoCao").Range("J3:N1000").ClearContents
    
    'Xac dinh dong
    For RowNum = 2 To UBound(arrData, 1)    'Bo dong 1 tieu de
        If arrData(RowNum, 2) Like tenNV Then
            Exit For
        End If
    Next RowNum
    If RowNum > UBound(arrData, 1) Then
        MsgBox "Khong co du lieu F1"
        Exit Sub
    End If
    dicF1.Add layMaNVrow(arrData(RowNum, 2)), 1
    
    'Lay du lieu tu rownum
    j = 0
    ReDim arrF1(300)
    For i = 4 To UBound(arrData, 2) - 1
        If arrData(RowNum, i) Like dk And Not layMaNVrow(arrData(RowNum, 2)) Like layMaNVcol(arrData(1, i)) Then
            arrF1(j) = arrData(1, i)
            dicF1.Add layMaNVcol(arrData(1, i)), j + 2
            j = j + 1
        End If
    Next i
    ReDim Preserve arrF1(j)
    Worksheets("BaoCao").Range("J3").Resize(UBound(arrF1, 1)).Value = WorksheetFunction.Transpose(arrF1)
    
    '    For i = 0 To dicF1.Count - 1
    '        Debug.Print dicF1.Keys()(i), dicF1.Items()(i)
    '    Next i
    
    
    '// Xac dinh F2 -----------------------------------------------
    j = 0   '** de noi lien tiep F2
    ReDim arrF2(500, 1)
    For i = 0 To UBound(arrF1) - 1
        For RowNum = 2 To UBound(arrData, 1)    'Xac dinh dong
            If layMaNVrow(arrData(RowNum, 2)) Like layMaNVcol(arrF1(i)) Then
                Exit For
            End If
        Next RowNum
        
        arrF2(j, 0) = arrF1(i) 'arrData(RowNum, 2) & " - " & arrData(RowNum, 3)
        If RowNum > UBound(arrData, 1) Then
            j = j + 1   'nhay dong ke neu F1 khong nam trong cot doc(khong co F2)
            GoTo skipf1
        End If
        n = j   'nhay dong ke neu F1 khong co F2
        For k = 4 To UBound(arrData, 2)
            If arrData(RowNum, k) Like dk And dicF1.Exists(layMaNVcol(arrData(1, k))) = False Then
                If dicF2.Exists(layMaNVcol(arrData(1, k))) = False Then
                    arrF2(j, 0) = arrF1(i) 'arrData(RowNum, 2) & " - " & arrData(RowNum, 3)  '
                    arrF2(j, 1) = arrData(1, k)
                    dicF2.Add layMaNVcol(arrData(1, k)), arrData(1, k)
                    j = j + 1
                End If
            End If
        Next k
        If j = n Then j = j + 1
skipf1:
    Next i
    arrF2 = ReDimPreserve(arrF2, j, 2)
    
    '------------------------------------------------------------------/
    
    '//Xac dinh F3
    j = 0   '** de noi lien tiep F3
    ReDim arrF3(1000, 1)
    For i = 0 To dicF2.Count - 1
        For RowNum = 2 To UBound(arrData, 1)    'Xac dinh dong
            If layMaNVrow(arrData(RowNum, 2)) Like dicF2.Keys()(i) Then
                Exit For
            End If
        Next RowNum
         If RowNum > UBound(arrData, 1) Then
            j = j + 1
            GoTo skipf2
        End If
        arrF3(j, 0) = dicF2.Items()(i) 'arrData(RowNum, 2) & " - " & arrData(RowNum, 3)
        n = j   'nhay dong ke neu F2 khong co F3
        For k = 4 To UBound(arrData, 2) - 1
            If arrData(RowNum, k) Like dk And dicF1.Exists(layMaNVcol(arrData(1, k))) = False And dicF2.Exists(layMaNVcol(arrData(1, k))) = False Then
                If dicF3.Exists(layMaNVcol(arrData(1, k))) = False Then
                    arrF3(j, 0) = dicF2.Items()(i) 'arrData(RowNum, 2) & " - " & arrData(RowNum, 3)
                    arrF3(j, 1) = arrData(1, k)
                    dicF3.Add layMaNVcol(arrData(1, k)), arrData(1, k)
                    j = j + 1
                End If
                
            End If
        Next k
        If j = n Then j = j + 1
skipf2:
    Next i
    arrF3 = ReDimPreserve(arrF3, j, 2)
    'Debug.Print dicF3.Count
    '---------------------------------------------------------/
    
    Worksheets("BaoCao").Range("K3").Resize(UBound(arrF2, 1), UBound(arrF2, 2)).Value = arrF2
    Worksheets("BaoCao").Range("M3").Resize(UBound(arrF3, 1), UBound(arrF3, 2)).Value = arrF3
    
    MsgBox "Xong."
    
    Erase arrF1
    Erase arrF2
    Erase arrF3
    Set dicF1 = Nothing
    Set dicF2 = Nothing
    Set dicF3 = Nothing
    
    Sheets("BaoCao").PivotTables("PivotTable1").RefreshTable
    Sheets("BaoCao").PivotTables("PivotTable2").RefreshTable
    
End Sub

Xuanhuy175995 · 20/8/21

ongke0711 đã viết:

Tôi chỉ xử lý được theo dạng này thôi. Code xử lý lại dữ liệu phù hợp cho việc dùng Pivot.

View attachment 264433

Mã:

Sub TongHop_C1()
   
    Dim arrData() As Variant, arrF1() As Variant, arrF2() As Variant, arrF3() As Variant
    Dim dicF1 As Dictionary, dicF2 As Dictionary, dicF3 As Dictionary
    Dim tenNV$, dk$, RowNum&, i&, j&, k&, n&
   
    Set dicF1 = New Dictionary
    Set dicF2 = New Dictionary
    Set dicF3 = New Dictionary
   
    arrData = Sheet1.UsedRange.Value
    tenNV = Sheet2.Range("B3")
    dk = Sheet2.Range("B4")
   
    Worksheets("BaoCao").Range("J3:N1000").ClearContents
   
    'Xac dinh dong
    For RowNum = 2 To UBound(arrData, 1)    'Bo dong 1 tieu de
        If arrData(RowNum, 2) Like tenNV Then
            Exit For
        End If
    Next RowNum
    If RowNum > UBound(arrData, 1) Then
        MsgBox "Khong co du lieu F1"
        Exit Sub
    End If
    dicF1.Add layMaNVrow(arrData(RowNum, 2)), 1
   
    'Lay du lieu tu rownum
    j = 0
    ReDim arrF1(300)
    For i = 4 To UBound(arrData, 2) - 1
        If arrData(RowNum, i) Like dk And Not layMaNVrow(arrData(RowNum, 2)) Like layMaNVcol(arrData(1, i)) Then
            arrF1(j) = arrData(1, i)
            dicF1.Add layMaNVcol(arrData(1, i)), j + 2
            j = j + 1
        End If
    Next i
    ReDim Preserve arrF1(j)
    Worksheets("BaoCao").Range("J3").Resize(UBound(arrF1, 1)).Value = WorksheetFunction.Transpose(arrF1)
   
    '    For i = 0 To dicF1.Count - 1
    '        Debug.Print dicF1.Keys()(i), dicF1.Items()(i)
    '    Next i
   
   
    '// Xac dinh F2 -----------------------------------------------
    j = 0   '** de noi lien tiep F2
    ReDim arrF2(500, 1)
    For i = 0 To UBound(arrF1) - 1
        For RowNum = 2 To UBound(arrData, 1)    'Xac dinh dong
            If layMaNVrow(arrData(RowNum, 2)) Like layMaNVcol(arrF1(i)) Then
                Exit For
            End If
        Next RowNum
       
        arrF2(j, 0) = arrF1(i) 'arrData(RowNum, 2) & " - " & arrData(RowNum, 3)
        If RowNum > UBound(arrData, 1) Then
            j = j + 1   'nhay dong ke neu F1 khong nam trong cot doc(khong co F2)
            GoTo skipf1
        End If
        n = j   'nhay dong ke neu F1 khong co F2
        For k = 4 To UBound(arrData, 2)
            If arrData(RowNum, k) Like dk And dicF1.Exists(layMaNVcol(arrData(1, k))) = False Then
                If dicF2.Exists(layMaNVcol(arrData(1, k))) = False Then
                    arrF2(j, 0) = arrF1(i) 'arrData(RowNum, 2) & " - " & arrData(RowNum, 3)  '
                    arrF2(j, 1) = arrData(1, k)
                    dicF2.Add layMaNVcol(arrData(1, k)), arrData(1, k)
                    j = j + 1
                End If
            End If
        Next k
        If j = n Then j = j + 1
skipf1:
    Next i
    arrF2 = ReDimPreserve(arrF2, j, 2)
   
    '------------------------------------------------------------------/
   
    '//Xac dinh F3
    j = 0   '** de noi lien tiep F3
    ReDim arrF3(1000, 1)
    For i = 0 To dicF2.Count - 1
        For RowNum = 2 To UBound(arrData, 1)    'Xac dinh dong
            If layMaNVrow(arrData(RowNum, 2)) Like dicF2.Keys()(i) Then
                Exit For
            End If
        Next RowNum
         If RowNum > UBound(arrData, 1) Then
            j = j + 1
            GoTo skipf2
        End If
        arrF3(j, 0) = dicF2.Items()(i) 'arrData(RowNum, 2) & " - " & arrData(RowNum, 3)
        n = j   'nhay dong ke neu F2 khong co F3
        For k = 4 To UBound(arrData, 2) - 1
            If arrData(RowNum, k) Like dk And dicF1.Exists(layMaNVcol(arrData(1, k))) = False And dicF2.Exists(layMaNVcol(arrData(1, k))) = False Then
                If dicF3.Exists(layMaNVcol(arrData(1, k))) = False Then
                    arrF3(j, 0) = dicF2.Items()(i) 'arrData(RowNum, 2) & " - " & arrData(RowNum, 3)
                    arrF3(j, 1) = arrData(1, k)
                    dicF3.Add layMaNVcol(arrData(1, k)), arrData(1, k)
                    j = j + 1
                End If
               
            End If
        Next k
        If j = n Then j = j + 1
skipf2:
    Next i
    arrF3 = ReDimPreserve(arrF3, j, 2)
    'Debug.Print dicF3.Count
    '---------------------------------------------------------/
   
    Worksheets("BaoCao").Range("K3").Resize(UBound(arrF2, 1), UBound(arrF2, 2)).Value = arrF2
    Worksheets("BaoCao").Range("M3").Resize(UBound(arrF3, 1), UBound(arrF3, 2)).Value = arrF3
   
    MsgBox "Xong."
   
    Erase arrF1
    Erase arrF2
    Erase arrF3
    Set dicF1 = Nothing
    Set dicF2 = Nothing
    Set dicF3 = Nothing
   
    Sheets("BaoCao").PivotTables("PivotTable1").RefreshTable
    Sheets("BaoCao").PivotTables("PivotTable2").RefreshTable
   
End Sub

Mình xin cảm ơn nhiều ạ

Xin hướng dẫn xây dựng công thức truy xuất thông tin nhanh dùm cho việc truy vết thông tin (2 người xem)

Người dùng đang xem chủ đề này

Xuanhuy175995

Thành viên mới

File đính kèm

ongke0711

Thành viên gắn bó

Xuanhuy175995

Thành viên mới

ongke0711

Thành viên gắn bó

File đính kèm

Xuanhuy175995

Thành viên mới

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

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

Sinh nhật lần 19 GPE