Lọc dữ liệu tự động từ sheet khác

[nhoc_khun]

Tôi chưa tìm được cách nào phù hợp cho trường hợp sau nên gửi lên nhờ mọi người chỉ giúp.
Trong file tôi gửi kèm có 2 sheet, một PHAN CONG và một là TONG HOP.
Ở PHAN CONG thì ngày tháng được bố trí theo CỘT (mặc định ở cột), và tên người thì được bố trí theo 21 cột tiếp theo đó.
Ở TONG HOP thì ngày tháng lại chuyển sang bố trí theo HÀNG NGANG (mặc định như vậy).
Yêu cầu chuyển dữ liệu tự động từ sheet PHAN CONG sang TONG HOP như sau:
Ví dụ
Nếu ở hàng ngày 1/1/11 (sheet PHAN CONG) có ông A1 được bố trí công việc thì sẽ đánh dấu "x" vào cột ngày 1/1/11(sheet TONG HOP), tương tự như các người khác.
Nếu trong hàng ngày 1/1/11 (ở sheet PHAN CONG ) không có ông D1,D2, D3, D4 thì tương ứng trong cột ngày 1/1/11 (sheet TONG HOP) sẽ để trống.
và các ngày khác cũng làm tương tự nhu vậy.
Rât mong sụ giúp đỡ của mọi người.

 

[concogia]

Tôi chưa tìm được cách nào phù hợp cho trường hợp sau nên gửi lên nhờ mọi người chỉ giúp.
Trong file tôi gửi kèm có 2 sheet, một PHAN CONG và một là TONG HOP.
Ở PHAN CONG thì ngày tháng được bố trí theo CỘT (mặc định ở cột), và tên người thì được bố trí theo 21 cột tiếp theo đó.
Ở TONG HOP thì ngày tháng lại chuyển sang bố trí theo HÀNG NGANG (mặc định như vậy).
Yêu cầu chuyển dữ liệu tự động từ sheet PHAN CONG sang TONG HOP như sau:
Ví dụ
Nếu ở hàng ngày 1/1/11 (sheet PHAN CONG) có ông A1 được bố trí công việc thì sẽ đánh dấu "x" vào cột ngày 1/1/11(sheet TONG HOP), tương tự như các người khác.
Nếu trong hàng ngày 1/1/11 (ở sheet PHAN CONG ) không có ông D1,D2, D3, D4 thì tương ứng trong cột ngày 1/1/11 (sheet TONG HOP) sẽ để trống.
và các ngày khác cũng làm tương tự nhu vậy.
Rât mong sụ giúp đỡ của mọi người.

RightClick vào sheet "TONG HOP" ==> ViewCode ==> Chép "thằng" này vào

Private Sub Worksheet_Activate()
    Dim Vung, I, J, K, Ws, TH, VungDo, Mg(), mM
    Set Ws = Sheets("PHAN CONG"):  Set TH = Sheets("TONG HOP")
    Set Vung = Ws.Range(Ws.[c2], Ws.[c1000].End(xlUp)).Resize(, 23)
    Set VungDo = TH.Range(TH.[a3], TH.[a1000].End(xlUp))
    ReDim Mg(1 To VungDo.Rows.Count, 1 To 31)
        For I = 1 To Vung.Rows.Count
            For J = 1 To Vung.Columns.Count
                For K = 1 To VungDo.Rows.Count
                    If VungDo(K) = Vung(I, J) Then Mg(K, I) = "x"
                Next K
            Next J
        Next I
    TH.[b3].Resize(VungDo.Rows.Count, 31) = Mg
End Sub

Xong
Nhập dữ liệu ở sheet "PHAN CONG" ==> chon sheet "TONG HOP" sẽ thấy kết quả
Bạn thử thay đổi dữ liệu rồi kiểm tra giúp mình nhé
Thân

 

[SA_DQ]

/-)ua tốc độ với ConCoGia cái chơi!

Option Explicit
Sub DuaTocDoVoiCoGia()
 Dim Timer_ As Double, Jj As Long, Ww As Long
 Dim Sh As Worksheet, nRng As Range, Cls As Range, sRng As Range
 Dim sRg As Range, Clls As Range, Rng As Range
 
 Timer_ = Timer:                Sheet1.Select
 Set Sh = ThisWorkbook.Worksheets("THop")
 Sh.[B2].CurrentRegion.Offset(2, 1).ClearContents
 Set nRng = Sh.Range(Sh.[A2], Sh.[A2].End(xlToRight))
 Set Rng = Sh.Range(Sh.[A2], Sh.[A65500].End(xlUp))
 For Each Cls In Range([B2], [b65500].End(xlUp))
    Set sRg = nRng.Find(Cls.Value, , xlFormulas, xlWhole)
    If Not sRg Is Nothing Then
        For Each Clls In Range(Cls.Offset(, 1), Cells(Cls.Row, "IV").End(xlToLeft))
            Set sRng = Rng.Find(Clls.Value)
            If Not sRng Is Nothing Then
                Sh.Cells(sRng.Row, sRg.Column).Value = "X"
            End If
        Next Clls
    End If
 Next Cls
 Sh.[a1].Value = Timer - Timer_
End Sub

 

[concogia]

Option Explicit
Sub DuaTocDoVoiCoGia()
Dim Timer_ As Double, Jj As Long, Ww As Long
Dim Sh As Worksheet, nRng As Range, Cls As Range, sRng As Range
Dim sRg As Range, Clls As Range, Rng As Range
 
Timer_ = Timer: Sheet1.Select
Set Sh = ThisWorkbook.Worksheets("THop")
Sh.[B2].CurrentRegion.Offset(2, 1).ClearContents
Set nRng = Sh.Range(Sh.[A2], Sh.[A2].End(xlToRight))
Set Rng = Sh.Range(Sh.[A2], Sh.[A65500].End(xlUp))
For Each Cls In Range([B2], [b65500].End(xlUp))
Set sRg = nRng.Find(Cls.Value, , xlFormulas, xlWhole)
If Not sRg Is Nothing Then
For Each Clls In Range(Cls.Offset(, 1), Cells(Cls.Row, "IV").End(xlToLeft))
Set sRng = Rng.Find(Clls.Value)
If Not sRng Is Nothing Then
Sh.Cells(sRng.Row, sRg.Column).Value = "X"
End If
Next Clls
End If
Next Cls
Sh.[a1].Value = Timer - Timer_
End Sub

Híc, hôm qua sinh nhật Ku Tùng, concogia gọi Bác Sa ra đọ bia mà có người hổng dám nghe máy, hihi
Tiếp "zí" bác Sa một chiêu

Public Sub DuaZiBacSa()
Dim Vung, I, J, K, Ws, TH, VungDo, Mg(), mM, Tg As Double
 Tg = Timer
    Set Ws = Sheets("PHAN CONG"):  Set TH = Sheets("TONG HOP")
    Vung = Ws.Range(Ws.[c2], Ws.[c1000].End(xlUp)).Resize(, 23).Value
    VungDo = TH.Range(TH.[a3], TH.[a1000].End(xlUp)).Value
    ReDim Mg(1 To UBound(VungDo), 1 To 31)
        For I = 1 To Ws.Range(Ws.[c2], Ws.[c1000].End(xlUp)).Rows.Count
            For J = 1 To 23
                For K = 1 To UBound(VungDo)
                    If VungDo(K, 1) = Vung(I, J) Then Mg(K, I) = "x"
                Next K
            Next J
        Next I
    TH.[b3].Resize(UBound(VungDo), 31) = Mg
MsgBox "Tg :" & Timer - Tg
End Sub

Híc, điện thoại reo mà hổng dám bắt là .........

 

[nhoc_khun]

Tôi rất cảm ơn các thành viên đã tận tình giúp đỡ