Kiểm tra trạng thái của sản phẩm mô phỏng theo chức năng PivotTable (1 người xem)

[tunglinhmot]

Chào anh chị em GPE. Em có một danh sách sản phẩm muốn kiểm tra trạng thái.
Bình thường nếu dùng PivotTable thì vẫn có thể làm được việc này nhưng em muốn làm nó đơn giản và nhanh hơn chỉ với một cú click chuột trong macro. Nhưng với khả năng hiện tại của em thì chưa thể làm được, nên em đăng chủ đề này nhờ các anh chị em trên GPE giúp em với ạ. Chi tiết cụ thể em xin trình bày trong file đính kèm đây ạ.

 

[giaiphap]

Chào anh chị em GPE. Em có một danh sách sản phẩm muốn kiểm tra trạng thái.
Bình thường nếu dùng PivotTable thì vẫn có thể làm được việc này nhưng em muốn làm nó đơn giản và nhanh hơn chỉ với một cú click chuột trong macro. Nhưng với khả năng hiện tại của em thì chưa thể làm được, nên em đăng chủ đề này nhờ các anh chị em trên GPE giúp em với ạ. Chi tiết cụ thể em xin trình bày trong file đính kèm đây ạ.

Bạn sử dụng thử code này xem sao.

Public Sub ToMau()
Dim i As Integer, k As Integer, Rng As Range, kt As Boolean
k = 3
For i = 3 To Range("B65000").End(xlUp).Row
    If Range("B" & i) <> Range("B" & (i + 1)) Then
        kt = True
        For Each Rng In Range("D" & k & ":D" & i)
            If Rng.Value <> "IPL" Then
                kt = False
                Exit For
            End If
            If kt Then Range("B" & k & ":D" & i).Interior.ThemeColor = xlThemeColorAccent6
        Next Rng
        k = i + 1
    End If
Next i
End Sub

 

[tunglinhmot]

Em đã check đoạn code của bác nhưng đoạn code này chỉ check được các part đầu tiên của từng obiect thôi, nếu trạng thái part đầu tiên của object là IPL nhưng trạng thái part thứ 2 hoặc thứ 3,4… là PR thì nó vẫn bôi màu, trong khi yêu cầu của bài toán là chỉ bôi màu các object nào có tất cả các parts đều là IPL, cái còn lại thì giữ nguyên.
(Cái còn lại là những object có tất cả trạng thái là PR hoặc 1 phần la IPL, 1 phần là PR. )
Bác xem lại cho em với.

 

[concogia]

Em đã check đoạn code của bác nhưng đoạn code này chỉ check được các part đầu tiên của từng obiect thôi, nếu trạng thái part đầu tiên của object là IPL nhưng trạng thái part thứ 2 hoặc thứ 3,4… là PR thì nó vẫn bôi màu, trong khi yêu cầu của bài toán là chỉ bôi màu các object nào có tất cả các parts đều là IPL, cái còn lại thì giữ nguyên.
(Cái còn lại là những object có tất cả trạng thái là PR hoặc 1 phần la IPL, 1 phần là PR. )
Bác xem lại cho em với.

Chạy thử code này xem sao:

Public Sub ToMau()
    Dim Vung, Mau, I, Tam, iDong, K
    Set Vung = Range([B2], [B50000].End(xlUp)).Resize(, 3)
    Vung.Interior.ColorIndex = xlNone
    Mau = 2
        For I = 2 To Vung.Rows.Count
            If Vung(I, 1) <> Vung(I - 1, 1) Then
                iDong = Application.WorksheetFunction.CountIf(Vung.Columns(1), Vung(I, 1))
                Set Tam = Vung(I, 1).Resize(iDong, 3)
                If Application.WorksheetFunction.CountIf(Tam.Columns(3), "IPL") = iDong Then
                    K = K + 1
                    Tam.Interior.ColorIndex = Mau + K
                End If
            End If
            I = I + iDong - 1
        Next I
End Sub

Thân
Hihi, bỏ bớt thằng IF cũng được, lúc đầu tính cho thằng I chạy hết bảng, sau thấy không cần. Lâu quá không viết bài nên mình đâm ra ngố quá. Huhuhu

 

[darknightno007]

Bạn check thử ok chưa nha.

Sub Test()
Dim Arr_Data(), oKey(), oItem()
Dim DicData As Dictionary

Set DicData = New Dictionary
Arr_Data = Sheet1.Range("B3:D33").Value

For K = 1 To UBound(Arr_Data, 1)
    If DicData.Exists(Arr_Data(K, 1)) = False Then
        If Arr_Data(K, 3) = "IPL" Then
            DicData.Add Arr_Data(K, 1), Array(K, 1, 1)
        Else
            DicData.Add Arr_Data(K, 1), Array(K, 1, 0)
        End If
       
    Else
            oItem = DicData.Item(Arr_Data(K, 1))
            oItem(1) = oItem(1) + 1
            If Arr_Data(K, 3) = "IPL" Then
                 oItem(2) = oItem(2) + 1
            End If
            DicData.Item(Arr_Data(K, 1)) = oItem
    End If
Next K
oKey = DicData.Keys
For I = LBound(oKey, 1) To UBound(oKey, 1)
    If DicData.Item(oKey(I))(1) = DicData.Item(oKey(I))(2) Then
        Sheet1.Range("B2").Offset(DicData.Item(oKey(I))(0), 0).Resize(DicData.Item(oKey(I))(1), UBound(Arr_Data, 2)).Interior.Color = 255
    End If
Next
End Sub

 

[tunglinhmot]

Chạy thử code này xem sao:

Public Sub ToMau()
    Dim Vung, Mau, I, Tam, iDong, K
    Set Vung = Range([B2], [B50000].End(xlUp)).Resize(, 3)
    Vung.Interior.ColorIndex = xlNone
    Mau = 2
        For I = 2 To Vung.Rows.Count
            If Vung(I, 1) <> Vung(I - 1, 1) Then
                iDong = Application.WorksheetFunction.CountIf(Vung.Columns(1), Vung(I, 1))
                Set Tam = Vung(I, 1).Resize(iDong, 3)
                If Application.WorksheetFunction.CountIf(Tam.Columns(3), "IPL") = iDong Then
                    K = K + 1
                    Tam.Interior.ColorIndex = Mau + K
                End If
            End If
            I = I + iDong - 1
        Next I
End Sub

Thân
Hihi, bỏ bớt thằng IF cũng được, lúc đầu tính cho thằng I chạy hết bảng, sau thấy không cần. Lâu quá không viết bài nên mình đâm ra ngố quá. Huhuhu

Em thử rồi, chạy OK bác ạ. Nhưng bác bôi nhiều màu quá

 

[tunglinhmot]

Bạn check thử ok chưa nha.

Sub Test()
Dim Arr_Data(), oKey(), oItem()
Dim DicData As Dictionary

Set DicData = New Dictionary
Arr_Data = Sheet1.Range("B3:D33").Value

For K = 1 To UBound(Arr_Data, 1)
    If DicData.Exists(Arr_Data(K, 1)) = False Then
        If Arr_Data(K, 3) = "IPL" Then
            DicData.Add Arr_Data(K, 1), Array(K, 1, 1)
        Else
            DicData.Add Arr_Data(K, 1), Array(K, 1, 0)
        End If
      
    Else
            oItem = DicData.Item(Arr_Data(K, 1))
            oItem(1) = oItem(1) + 1
            If Arr_Data(K, 3) = "IPL" Then
                 oItem(2) = oItem(2) + 1
            End If
            DicData.Item(Arr_Data(K, 1)) = oItem
    End If
Next K
oKey = DicData.Keys
For I = LBound(oKey, 1) To UBound(oKey, 1)
    If DicData.Item(oKey(I))(1) = DicData.Item(oKey(I))(2) Then
        Sheet1.Range("B2").Offset(DicData.Item(oKey(I))(0), 0).Resize(DicData.Item(oKey(I))(1), UBound(Arr_Data, 2)).Interior.Color = 255
    End If
Next
End Sub

Code của bác em chạy bị lỗi ở chỗ Dim DicData As Dictionary bác ạ.
Em cũng thử tự mày mò và cũng đã tìm ra được 1 cách, em sửa lại code ban đầu của bác giaiphap như sau :

Public Sub ToMau()
Dim i As Integer, k As Integer, Rng As Range, kt As Boolean
k = 3
For i = 3 To Range("B65000").End(xlUp).Row
    If Range("B" & i) <> Range("B" & (i + 1)) Then
        kt = True
        For Each Rng In Range("D" & k & ":D" & i)
            If Rng.Value <> "IPL" Then
                kt = False
                Exit For
                
             Else: GoTo err:
            
            End If
          
err:
      
        Next Rng
         If kt Then Range("B" & k & ":D" & i).Interior.ThemeColor = xlThemeColorAccent6
        k = i + 1
    End If
Next i
End Sub

 

[concogia]

Em thử rồi, chạy OK bác ạ. Nhưng bác bôi nhiều màu quá

Có lý do cả, nếu nhiều hơn 2 nhóm có Status là "IPL" hết mà đứng sát nhau, bôi một màu đỏ lè lè thì ai biết nhóm nào với nhóm nào. Híc
Thân

 

[darknightno007]

Code của bác em chạy bị lỗi ở chỗ Dim DicData As Dictionary bác ạ.
Em cũng thử tự mày mò và cũng đã tìm ra được 1 cách, em sửa lại code ban đầu của bác giaiphap như sau :

Public Sub ToMau()
Dim i As Integer, k As Integer, Rng As Range, kt As Boolean
k = 3
For i = 3 To Range("B65000").End(xlUp).Row
    If Range("B" & i) <> Range("B" & (i + 1)) Then
        kt = True
        For Each Rng In Range("D" & k & ":D" & i)
            If Rng.Value <> "IPL" Then
                kt = False
                Exit For
               
             Else: GoTo err:
           
            End If
         
err:
     
        Next Rng
         If kt Then Range("B" & k & ":D" & i).Interior.ThemeColor = xlThemeColorAccent6
        k = i + 1
    End If
Next i
End Sub

cái đó mình dùng Dictionary, bạn thêm thư viện Microsoft Scripting Runtime là chạy được thôi.