Tìm kiểu màu trong danh sách.

Quảng cáo

emgaimuarao

Thành viên hoạt động
Tham gia ngày
30 Tháng chín 2016
Bài viết
116
Được thích
29
Điểm
118
20210208_144454.jpg
Bài này em làm mãi không được ạ. Các thầy và anh chị giúp em với.
 

File đính kèm

  • Dammau1.xlsx
    9.9 KB · Đọc: 15
Lần chỉnh sửa cuối:

ptm0412

Bad Excel Member
Thành viên BQT
Super Moderator
Tham gia ngày
4 Tháng mười một 2007
Bài viết
10,519
Được thích
30,886
Điểm
9,718
Tuổi
59
Nơi ở
Gò Vấp
Bác lài bồi cho một chùy như vậy nữa. Ác
Không nên viết tiêu đề gợi cảm xúc
Chạy code sau, sau đó CountIf với F là sum C, D, E
Mã:
Sub CellColor()
For Each cel In Union(Range("h5:j8"), Range("C5:E14"))
    cel.Value = cel.Interior.Color
    cel.Font.Color = cel.Value
Next
End Sub
1612772206616.png
 

emgaimuarao

Thành viên hoạt động
Tham gia ngày
30 Tháng chín 2016
Bài viết
116
Được thích
29
Điểm
118
Không nên viết tiêu đề gợi cảm xúc
Chạy code sau, sau đó CountIf với F là sum C, D, E
Mã:
Sub CellColor()
For Each cel In Union(Range("h5:j8"), Range("C5:E14"))
    cel.Value = cel.Interior.Color
    cel.Font.Color = cel.Value
Next
End Sub
View attachment 254072
Em cảm ơn thầy.
Liệu có thể nâng cấp code tiếp nên nấc nữa được không thầy(không dùng cột F và hàm countif)mà gắn vào nút. Rồi em dí 1 cái nó tòi ra ở cột K không ạ?
 
Lần chỉnh sửa cuối:

VetMini

Chuyên gia GPE
Tham gia ngày
21 Tháng mười hai 2012
Bài viết
11,031
Được thích
13,681
Điểm
4,868
Thì cứ dùng phương pháp "cổ điển gia truyền của GPE": đít sần

For Each rg In Range("M5:Q14").Rows
ki = CStr(rg.Cells(1,1).Interior.Color) & "|" & CStr(rg.Cells(1,2).Interior.Color) & "|" & CStr(rg.Cells(1,3).Interior.Color)
ditSan(ki) = ditSan(ki) + 1
Next rg
Set rg = Range("g5:k5").ReSize(ditSan.Count, )
For i = 1 To ditSan.Count
ki = Split(diSan.Keys()(i-1), "|")
rg.Cells(i, 1).Value = i
rg.Cells(i, 2).Interior.Color = CLng(ki(0))
rg.Cells(i, 3).Interior.Color = CLng(ki(1))
rg.Cells(i, 4).Interior.Color = CLng(ki(2))
rg.Cells(i, 5).Value = ditSan.Items()(i-1)
Next i
 

emgaimuarao

Thành viên hoạt động
Tham gia ngày
30 Tháng chín 2016
Bài viết
116
Được thích
29
Điểm
118
Thì cứ dùng phương pháp "cổ điển gia truyền của GPE": đít sần

For Each rg In Range("M5:Q14").Rows
ki = CStr(rg.Cells(1,1).Interior.Color) & "|" & CStr(rg.Cells(1,2).Interior.Color) & "|" & CStr(rg.Cells(1,3).Interior.Color)
ditSan(ki) = ditSan(ki) + 1
Next rg
Set rg = Range("g5:k5").ReSize(ditSan.Count, )
For i = 1 To ditSan.Count
ki = Split(diSan.Keys()(i-1), "|")
rg.Cells(i, 1).Value = i
rg.Cells(i, 2).Interior.Color = CLng(ki(0))
rg.Cells(i, 3).Interior.Color = CLng(ki(1))
rg.Cells(i, 4).Interior.Color = CLng(ki(2))
rg.Cells(i, 5).Value = ditSan.Items()(i-1)
Next i
Untitled.jpg
Vẫn chưa chạy được ạ. Code tinh vi quá, thấy có mấy cái que "l" em không biết cảnh làm cho hết đo đỏ. Full code như nào thầy giúp em tý.
 

phuocam

Thành viên mới
Tham gia ngày
16 Tháng năm 2013
Bài viết
2,962
Được thích
4,144
Điểm
1,568
Lần chỉnh sửa cuối:

phuocam

Thành viên mới
Tham gia ngày
16 Tháng năm 2013
Bài viết
2,962
Được thích
4,144
Điểm
1,568
Thử UDF này:

PHP:
Public Function CountColors(ByVal rngData As Range, ByVal rngTemp As Range) As Long
Application.Volatile
Dim i As Long, j As Long
Dim col As Long
col = rngData.Columns.Count

For i = 1 To rngData.Rows.Count
    For j = 1 To col
        If rngData.Cells(i, j).Interior.Color <> rngTemp.Cells(1, j).Interior.Color Then Exit For
    Next j
    If j > col Then CountColors = CountColors + 1
Next i

End Function
Trong ô K5 nhập:

=CountColors($C$5:$E$14,H5:J5)
 

emgaimuarao

Thành viên hoạt động
Tham gia ngày
30 Tháng chín 2016
Bài viết
116
Được thích
29
Điểm
118
Thử UDF này:

PHP:
Public Function CountColors(ByVal rngData As Range, ByVal rngTemp As Range) As Long
Application.Volatile
Dim i As Long, j As Long
Dim col As Long
col = rngData.Columns.Count

For i = 1 To rngData.Rows.Count
    For j = 1 To col
        If rngData.Cells(i, j).Interior.Color <> rngTemp.Cells(1, j).Interior.Color Then Exit For
    Next j
    If j > col Then CountColors = CountColors + 1
Next i

End Function
Trong ô K5 nhập:

=CountColors($C$5:$E$14,H5:J5)
Vâng.Quá tuyệt vời, Phần mềm này Mỹ tạo ra cho người Việt dùng.Code chay thích lắm ạ.Cảm ơn thầy đã giúp em ạ.
Thầy có ghé lại thêm cho em cái Sub, em sơ đẳng thêm chút thì học được thêm ạ
 
Lần chỉnh sửa cuối:

ptm0412

Bad Excel Member
Thành viên BQT
Super Moderator
Tham gia ngày
4 Tháng mười một 2007
Bài viết
10,519
Được thích
30,886
Điểm
9,718
Tuổi
59
Nơi ở
Gò Vấp
Rồi em dí 1 cái nó tòi ra ở cột K không ạ?
Dí cái gì vào cái gì và tòi ra cái gì? Toàn dùng từ gợi cảm ... xúc. Tôi có code (cũng đít sần) nhưng không dí cũng không tòi
PHP:
Sub CountColor()
Dim Dict, SampleRng As Range, DataRng As Range
Dim LastRw As Long, TotalColor As Long, RArr(), Tmp As Long
With Sheet1
    LastRw = .Cells(1000, 2).End(xlUp).Row
    Set SampleRng = .Range("H5:J8")
    Set DataRng = .Range("C5:E" & LastRw)
    Set Dict = CreateObject("Scripting.Dictionary")
    For i = 1 To SampleRng.Rows.Count
        TotalColor = SampleRng.Cells(i, 1).Interior.Color + _
            SampleRng.Cells(i, 2).Interior.Color + _
            SampleRng.Cells(i, 3).Interior.Color
        Dict.Add TotalColor, i
    Next
    ReDim RArr(1 To Dict.Count, 1 To 1)
    For i = 1 To DataRng.Rows.Count
        TotalColor = DataRng.Cells(i, 1).Interior.Color + _
            DataRng.Cells(i, 2).Interior.Color + _
            DataRng.Cells(i, 3).Interior.Color
        Tmp = Dict.Item(TotalColor)
        RArr(Tmp, 1) = RArr(Tmp, 1) + 1
    Next
    .Range("K5").Resize(Dict.Count, 1) = RArr
End With
End Sub
Nhớ xoá trắng bên dưới dữ liệu cột B
 
Lần chỉnh sửa cuối:

emgaimuarao

Thành viên hoạt động
Tham gia ngày
30 Tháng chín 2016
Bài viết
116
Được thích
29
Điểm
118
Dí cái gì vào cái gì và tòi ra cái gì? Toàn dùng từ gợi cảm ... xúc. Tôi có code (cũng đít sần) nhưng không dí cũng không tòi
PHP:
Sub CountColor()
Dim DictColor, SampleRng As Range, DataRng As Range
Dim LastRw As Long, TotalColor As Long, RArr(), Tmp As Long
With Sheet1
    LastRw = .Cells(1000, 2).End(xlUp).Row
    Set SampleRng = .Range("H5:J8")
    Set DataRng = .Range("C5:E" & LastRw)
    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To SampleRng.Rows.Count
        TotalColor = SampleRng.Cells(i, 1).Interior.Color + _
            SampleRng.Cells(i, 2).Interior.Color + _
            SampleRng.Cells(i, 3).Interior.Color
        dict.Add TotalColor, i
    Next
    ReDim RArr(1 To dict.Count, 1 To 1)
    For i = 1 To DataRng.Rows.Count
        TotalColor = DataRng.Cells(i, 1).Interior.Color + _
            DataRng.Cells(i, 2).Interior.Color + _
            DataRng.Cells(i, 3).Interior.Color
        Tmp = dict.Item(TotalColor)
        RArr(Tmp, 1) = RArr(Tmp, 1) + 1
    Next
    .Range("K5").Resize(dict.Count, 1) = RArr
End With
End Sub
Nhớ xoá trắng bên dưới dữ liệu cột B
Mừng quá. Nhân đây em chúc thầy và các thầy hay giúp đỡ các em be bé như chúng em năm mới nhiều sức khỏe và thành đạt, thông công.
Ơ trên có từ "...xúc"
 
Lần chỉnh sửa cuối:

VetMini

Chuyên gia GPE
Tham gia ngày
21 Tháng mười hai 2012
Bài viết
11,031
Được thích
13,681
Điểm
4,868
Một câu hỏi Hóc và Búa. :D
Cái búa này hình dạng ra sao? Và cái gì hóc nó?

(*) búa có nhiều dạng tuỳ theo ngành nghề dùng: thợ rèn dùng búa tạ, thợ nguội dùng búa dập, thợ gò đồng dùng búa gõ, thợ mộc dùng búa đinh, thợ lát gạch dùng búa cao su.
Loại ngành nghề đóng cọc dùng loại búa áp lực, cứ nhịp nhàng mà dộng thẳng :p
 

emgaimuarao

Thành viên hoạt động
Tham gia ngày
30 Tháng chín 2016
Bài viết
116
Được thích
29
Điểm
118
Những người giỏi VBA,Excel đều là những trai tài gái sắc cả. Những người thành công thì giỏi nhiều thứ có thể có cả VBA,Excel...Nhưng giỏi VBA,Excel chắc chắn thành công ở linh vực của mình (hay gặp dân kỹ thuật, đầu có sạn ở đấy đấy)
 

emgaimuarao

Thành viên hoạt động
Tham gia ngày
30 Tháng chín 2016
Bài viết
116
Được thích
29
Điểm
118
Dí cái gì vào cái gì và tòi ra cái gì? Toàn dùng từ gợi cảm ... xúc. Tôi có code (cũng đít sần) nhưng không dí cũng không tòi
PHP:
Sub CountColor()
Dim Dict, SampleRng As Range, DataRng As Range
Dim LastRw As Long, TotalColor As Long, RArr(), Tmp As Long
With Sheet1
    LastRw = .Cells(1000, 2).End(xlUp).Row
    Set SampleRng = .Range("H5:J8")
    Set DataRng = .Range("C5:E" & LastRw)
    Set Dict = CreateObject("Scripting.Dictionary")
    For i = 1 To SampleRng.Rows.Count
        TotalColor = SampleRng.Cells(i, 1).Interior.Color + _
            SampleRng.Cells(i, 2).Interior.Color + _
            SampleRng.Cells(i, 3).Interior.Color
        Dict.Add TotalColor, i
    Next
    ReDim RArr(1 To Dict.Count, 1 To 1)
    For i = 1 To DataRng.Rows.Count
        TotalColor = DataRng.Cells(i, 1).Interior.Color + _
            DataRng.Cells(i, 2).Interior.Color + _
            DataRng.Cells(i, 3).Interior.Color
        Tmp = Dict.Item(TotalColor)
        RArr(Tmp, 1) = RArr(Tmp, 1) + 1
    Next
    .Range("K5").Resize(Dict.Count, 1) = RArr
End With
End Sub
Nhớ xoá trắng bên dưới dữ liệu cột B
Chú Mỹ ơi!
Em chào các thầy và các anh chị ạ!
Sub CountColor chú và các thầy commet giống bài như trong ảnh giúp cháu(em) với ạ!
baigiaicau1.jpg
 

ptm0412

Bad Excel Member
Thành viên BQT
Super Moderator
Tham gia ngày
4 Tháng mười một 2007
Bài viết
10,519
Được thích
30,886
Điểm
9,718
Tuổi
59
Nơi ở
Gò Vấp

emgaimuarao

Thành viên hoạt động
Tham gia ngày
30 Tháng chín 2016
Bài viết
116
Được thích
29
Điểm
118
Căng quá chú Mỹ ạ! Môn VBA chỗ Thớt này nhiều "chữ" quá chú ạ!
Nhân đây nhờ chứ và các thầy chỉ cho cháu(em) bài tập như sau:
kieu.jpg
 

File đính kèm

  • KIEUTOHOP.xlsm
    23.4 KB · Đọc: 4
Lần chỉnh sửa cuối:

ptm0412

Bad Excel Member
Thành viên BQT
Super Moderator
Tham gia ngày
4 Tháng mười một 2007
Bài viết
10,519
Được thích
30,886
Điểm
9,718
Tuổi
59
Nơi ở
Gò Vấp
Nhân đây nhờ chứ và các thầy chỉ cho cháu(em) bài tập như sau:
Này thì chỉ:
- Không dùng Dict
- Dùng 1 vòng lặp duyệt qua các dòng của Range Data: nếu color1 = color2 thì tăng biến MN lên, nếu color2 = color3 thì tăng biến NQ lên
- gán 2 biến xuống 2 ô kết quả
 
Quảng cáo
Top Bottom