Có thể viết VBA tổng hợp chức năng Consolidate cho những Sheet có màu Tab như nhau (1 người xem)

[LinDan]

Em muốn viết Code dựa theo chức năng Consolidate theo điều kiện: Tự động cộng những Sheet nào mà có Tab cùng màu được không? (Tức tự động cộng theo màu của Tab chứ không dựa theo tiêu chí tên Sheet)

Em xin cảm ơn
---------
Cụ thể trong file đính kèm:
- 2 Sheet VL25, VL26 cùng màu Sheet nó tự động công với nhau, kết quả tạo Sheet mới.

- 2 Sheet HM25, HM26 cùng màu Sheet nó tự động công với nhau, kết quả tạo Sheet mới.

 

[Hai Lúa Miền Tây]

Em muốn viết Code dựa theo chức năng Consolidate theo điều kiện: Tự động cộng những Sheet nào mà có Tab cùng màu được không? (Tức tự động cộng theo màu của Tab chứ không dựa theo tiêu chí tên Sheet)

Em xin cảm ơn
---------
Cụ thể trong file đính kèm:
- 2 Sheet VL25, VL26 cùng màu Sheet nó tự động công với nhau, kết quả tạo Sheet mới.

- 2 Sheet HM25, HM26 cùng màu Sheet nó tự động công với nhau, kết quả tạo Sheet mới.

Làm đại cho bạn, bạn tự chỉnh lại vùng dữ liệu cho hợp lý nhé

Function UniqueArray(anArray As Variant) As Variant
Dim d As Object
Set d = CreateObject("Scripting.Dictionary")
    With d
        .CompareMode = TextCompare
        For Each a In anArray
            If Not Len(a) = 0 And Not .Exists(a) Then
                .Add a, Nothing
            End If
        Next a
        UniqueArray = d.keys
    End With
    Set d = Nothing
End Function
Sub Test()
Dim i As Integer, nSht As Integer, str1 As String, str2 As String, Arr As Variant
    For nSht = 1 To Worksheets.Count
        str1 = str1 & ";" & Worksheets(nSht).Tab.Color
    Next
    
    Arr = UniqueArray(Split(str1, ";"))
    
    For i = 0 To UBound(Arr)
        Sheets.Add AFTER:=Worksheets(Worksheets.Count)
        With ActiveSheet
             .Name = "Total " & Arr(i)
             For e = 1 To Worksheets.Count
                   If Worksheets(e).Tab.Color = Val(Arr(i)) Then
                   str2 = str2 & "," & "'" & ThisWorkbook.Path & "\[" & ThisWorkbook.Name & "]" & Worksheets(e).Name & "'!R6C1:R22C8"
                   End If
             Next
            .Tab.Color = Val(Arr(i))
            .[A2].Consolidate Sources:=Array(Split(Right(str2, Len(str2) - 1), ",")), _
                            Function:=xlSum, TopRow:=True, LeftColumn:=True, CreateLinks:=False
        .Cells.EntireColumn.AutoFit
        End With
        str2 = ""
    Next
    Erase Arr
End Sub