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
Đập là đập thế nào, lại bon chen. Cách khác không cần xử lý trồi với sụt đây:

PHP:
    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
        If Dict.Exists(TotalColor) Then RArr(Tmp, 1) = RArr(Tmp, 1) + 1
    Next
Cháu có thể hiểu đoạn này là loại bỏ kye không trùng phải không chú.
Tới tấp bài mới sướng quá nhìn lộn không phải chị Phương mà là của chú Mỹ 2 cách.
 

Hoàng Nhật Phương

Thành viên tích cực
Tham gia ngày
5 Tháng mười một 2015
Bài viết
1,595
Được thích
714
Điểm
668
Nơi ở
Hà Nội
Đúng là xử lý được bài #54. Chị giải thích thêm cho em 2 cái này.lõi như nhau sao hết được trồi ở bài#54 vậy chị?
Ủa thế OTnhầm, cứ OT cứ tưởn bạn muốn thêm kết quả như trong file mẫu 'Dammau1 1-cothemmoi.xlsm' bạn gửi ở 43, chính vì thế OT mới bảo bạn xử lý như bài 44:

1613492271346.png

Xin lỗi OT hiểu nhầm, haiz, đúng là không nên bon chen.:wallbash:
Bài đã được tự động gộp:

Pậy pạ nà. Bỏ cái trồi trồi đó là xong rồi
Xin lỗi Chú Mỹ nhé, vì file đính kèm có kết quả mẫu,con chạy code thấy lỗi nên xử lý code theo kết quả mẫu.
Bài 49 con đã rút nui rồi mà nhưng cái tật bon chen không bao giờ sửa được (@$%@
 

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,518
Được thích
30,886
Điểm
9,718
Tuổi
59
Nơi ở
Gò Vấp
Cháu có thể hiểu đoạn này là loại bỏ kye không trùng phải không chú.

Tới tấp bài mới sướng quá nhìn lộn không phải chị Phương mà là của chú Mỹ 2 cách.
Đã nói là key, không phải kye. Nó có nghĩa là "Nếu có tồn tại trong Dict" (tức là có giống với 1 mẫu), ngược lại (không giống mẫu nào) thì không làm gì cả (không có else)
Sướng quá giờ làm sao?

Xin lỗi Chú Mỹ nhé, vì file đính kèm có kết quả mẫu,con chạy code thấy lỗi nên xử lý code theo kết quả mẫu.
Bài 49 con đã rút nui rồi mà nhưng cái tật bon chen không bao giờ sửa được
Cần gì xử lý, lấy thủ tục testdemsomau() của bác @VetMini thêm biến dòng cuối là ra rồi. Nhưng do bon chen nên không đọc yêu cầu mới chỗ trồi trồi
 
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
Đã nói là key, không phải kye. Nó có nghĩa là "Nếu có tồn tại trong Dict" (tức là có giống với 1 mẫu), ngược lại (không giống mẫu nào) thì không làm gì cả (không có else)
Sướng quá giờ làm sao?


Cần gì xử lý, lấy thủ tục testdemsomau() của bác @VetMini thêm biến dòng cuối là ra rồi. Nhưng do bon chen nên không đọc yêu cầu mới chỗ trồi trồi
Thích quá giờ không biết làm sao. Làm thành viên diễn đàn chú đã sướng thế này. Nếu là hàng xóm thì... phải biết đấy.
Chú xử tiếp code của chú @VetMini. Giảng cho chúng cháu bài #55, #57 thì hiện tại đến đây mới là full bài Dictionary chú ạ!
 

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,518
Được thích
30,886
Điểm
9,718
Tuổi
59
Nơi ở
Gò Vấp
Thích quá giờ không biết làm sao. Làm thành viên diễn đàn chú đã sướng thế này. Nếu là hàng xóm thì... phải biết đấy.
Chú xử tiếp của code của chú @VetMini. Giảng cho chúng cháu bài #55, #57 thì hiện tại đến đây mới là full bài Dictionary chú ạ!
Nếu là hàng xóm thì sang đánh nhau à?
Bài 57 giải thích tại bài 63, còn bài 55:
PHP:
        Tmp = Dict.Item(TotalColor) 'add 1 key vào Dict với item rỗng'
        If Tmp <> 0 Then RArr(Tmp, 1) = RArr(Tmp, 1) + 1
Nghĩa là khi không có sẵn mẫu trùng, Dict vẫn bị add thêm 1 key là TotalColor với item rỗng (item rỗng lấy ra cho vào biến Tmp sẽ là 0). Chạy hết dữ liệu thì đã bị add vài ba lần như thế. Sau khi bị add thì Dict.Count tăng lên 7 không còn là 4 nữa. Trong khi RArr() giới hạn chỉ 4 dòng, K5 mà resize 7 dòng mà gán RArr 4 dòng thì 3 dòng lỗi NA.
Biện pháp là trước khi gán tào lao vô Dict thì Count Dict trước cho vào biến DictCount, (kết quả 4), K5 resize 4 khớp với RArr, hết lỗi NA
______
Code bác @VetMini thêm biến dòng cuối:
PHP:
Sub testdemsomau()
Dim ditSan, ki, LastRw As Long
LastRw = [B1000].End(xlUp).Row
Set ditSan = CreateObject("Scripting.Dictionary")
For Each rg In Range("B5:E" & LastRw).Rows
    ki = CStr(rg.Cells(1, 2).Interior.Color) & "|" & CStr(rg.Cells(1, 3).Interior.Color) & "|" & CStr(rg.Cells(1, 4).Interior.Color)
    ditSan(ki) = ditSan(ki) + 1
Next rg
Set rg = Range("G5:K5").Resize(ditSan.Count, 4)
For i = 1 To ditSan.Count
    ki = Split(ditSan.keys()(i - 1), "|")
    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
End Sub
Code đập đi làm lại:
PHP:
Sub countNotSample()
Dim Dict, DataRng As Range, LastRw As Long
Dim TotalColor As Long, RArr(), Tmp As Long
With Sheet1
    .Range("H5:K100").Clear
    LastRw = .Cells(10000, 2).End(xlUp).Row
    Set DataRng = .Range("C5:E" & LastRw)
    ReDim RArr(1 To DataRng.Rows.Count, 1 To 4)
    Set Dict = CreateObject("Scripting.Dictionary")
    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
        If Not Dict.Exists(TotalColor) Then
            k = k + 1
            Dict.Add TotalColor, k
            RArr(k, 1) = DataRng.Cells(i, 1).Interior.Color
            RArr(k, 2) = DataRng.Cells(i, 2).Interior.Color
            RArr(k, 3) = DataRng.Cells(i, 3).Interior.Color
            RArr(k, 4) = 1
        Else
            Tmp = Dict.Item(TotalColor)
            RArr(Tmp, 4) = RArr(Tmp, 4) + 1
        End If
    Next
    For i = 1 To k
        .Cells(i + 4, 8).Interior.Color = RArr(i, 1)
        .Cells(i + 4, 9).Interior.Color = RArr(i, 2)
        .Cells(i + 4, 10).Interior.Color = RArr(i, 3)
        .Cells(i + 4, 11) = RArr(i, 4)
    Next
End With
      
End Sub
 
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
Nếu là hàng xóm thì sang đánh nhau à?
Bài 57 giải thích tại bài 63, còn bài 55:
PHP:
        Tmp = Dict.Item(TotalColor) 'add 1 key vào Dict với item rỗng'
        If Tmp <> 0 Then RArr(Tmp, 1) = RArr(Tmp, 1) + 1
Nghĩa là khi không có sẵn mẫu trùng, Dict vẫn bị add thêm 1 key là TotalColor với item rỗng (item rỗng lấy ra cho vào biến Tmp sẽ là 0). Chạy hết dữ liệu thì đã bị add vài ba lần như thế. Sau khi bị add thì Dict.Count tăng lên 7 không còn là 4 nữa. Trong khi RArr() giới hạn chỉ 4 dòng, K5 mà resize 7 dòng mà gán RArr 4 dòng thì 3 dòng lỗi NA.
Biện pháp là trước khi gán tào lao vô Dict thì Count Dict trước cho vào biến DictCount, (kết quả 4), K5 resize 4 khớp với RArr, hết lỗi NA
______
Code bác @VetMini thêm biến dòng cuối:
PHP:
Sub testdemsomau()
Dim ditSan, ki, LastRw As Long
LastRw = [B1000].End(xlUp).Row
Set ditSan = CreateObject("Scripting.Dictionary")
For Each rg In Range("B5:E" & LastRw).Rows
    ki = CStr(rg.Cells(1, 2).Interior.Color) & "|" & CStr(rg.Cells(1, 3).Interior.Color) & "|" & CStr(rg.Cells(1, 4).Interior.Color)
    ditSan(ki) = ditSan(ki) + 1
Next rg
Set rg = Range("G5:K5").Resize(ditSan.Count, 4)
For i = 1 To ditSan.Count
    ki = Split(ditSan.keys()(i - 1), "|")
    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
End Sub
Code đập đi làm lại:
PHP:
Sub countNotSample()
Dim Dict, DataRng As Range, LastRw As Long
Dim TotalColor As Long, RArr(), Tmp As Long
With Sheet1
    .Range("H5:K100").Clear
    LastRw = .Cells(10000, 2).End(xlUp).Row
    Set DataRng = .Range("C5:E" & LastRw)
    ReDim RArr(1 To DataRng.Rows.Count, 1 To 4)
    Set Dict = CreateObject("Scripting.Dictionary")
    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
        If Not Dict.Exists(TotalColor) Then
            k = k + 1
            Dict.Add TotalColor, k
            RArr(k, 1) = DataRng.Cells(i, 1).Interior.Color
            RArr(k, 2) = DataRng.Cells(i, 2).Interior.Color
            RArr(k, 3) = DataRng.Cells(i, 3).Interior.Color
            RArr(k, 4) = 1
        Else
            Tmp = Dict.Item(TotalColor)
            RArr(Tmp, 1) = RArr(Tmp, 1) + 1
        End If
    Next
    For i = 1 To k
        .Cells(i + 4, 8).Interior.Color = RArr(i, 1)
        .Cells(i + 4, 9).Interior.Color = RArr(i, 2)
        .Cells(i + 4, 10).Interior.Color = RArr(i, 3)
        .Cells(i + 4, 11) = RArr(i, 4)
    Next
End With
       
End Sub
Hàng xóm với chú thì qua nhậu với chú với hát karaoke ạ. Chú ngủ sớm đi ạ. Chúc chú ngủ ngon ạ!
 
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,518
Đượ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
Nhờ bon chen nên chú tăng được mấy bài mắng, mà hễ mắng thì thêm mưa tim, chú tăng hạng. Cứ thế phát huy nhé :p
Lúc đấy cháu cũng sợ quá. Quả này bị ghét rồi. Không được chỉ nữa rồi. Lúc đấy buồn lắm may có chị Phương vào mới cảm thấy bớt bớt bị mắng. Bí quá biết làm mỗi động tác thả tim và hỏi đi hỏi lại.
Sau có bài tới lên bị sướng quá. Chắc do sợ quá hic hic.
 

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
...Dim TotalColor As Long, RArr(), Tmp As Long
... TotalColor = DataRng.Cells(i, 1).Interior.Color + _
DataRng.Cells(i, 2).Interior.Color + _
DataRng.Cells(i, 3).Interior.Color
...
Theo tôi hiểu thì cộng như vậy sẽ bị trùng.
Cùng số nhưng khác thứ tự:
3+4+5 = 12
4+3+5 = 12
Khác số, cùng tổng:
2+4+6 = 12

Nếu tôi lập keys màu thì tôi cộng chuỗi
Join(Array(3, 4, 5), ".") = "3.4.5"
Nếu thứ tự không phân biệt (đỏ, cam, vàng coi như vàng, cam, đỏ) thì phải sắp xế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
Gợi ý rồi mà.
Code này chỉ đếm mẫu có sẵn (4 mẫu), bỏ qua những dữ liệu không có trong mẫu sẽ không đếm. Đáng lẽ chỉ được nhập liệu với mẫu có sẵn, mẫu nào chưa có phải khai báo (giống như bảng mã chuẩn)
Ngoài ra mở rộng DataRng đến dòng cuối thay vì chỉ đến 19.
PHP:
Sub CountColor()
Dim Dict, SampleRng As Range, DataRng As Range
Dim TotalColor As Long, RArr(), Tmp As Long, LastRw As Long
With Sheet1
    Set SampleRng = .Range("H5:J8")
    LastRw = .Cells(10000, 2).End(xlUp).Row
    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)
        If Tmp <> 0 Then RArr(Tmp, 1) = RArr(Tmp, 1) + 1
    Next
    .Range("K5").Resize(Dict.Count, 1) = RArr
End With
End Sub
- Code ở bài #51 và cách sửa ở bài #55. Hiện đã giải quyết được vấn đề thêm mẫu mới bất kỳ ở bảng "NỘI LỰC DẦM HIỆN TẠI" và mẫu ở bảng "NỘI LỰC DẦM MẪU" cố định.
- Còn các code ở bài #65 vẫn bị trồi thêm dữ liệu và chép thêm mẫu mới vào bảng "NỘI LỰC DẦM MẪU" chú Mỹ ạ! Liệu có cách nào dùng cách tạo key của chú @VetMini vào bài #51 và #55 không chú @ptm0412 nhỉ.Nếu điều đó là làm được thì sẽ giải quyết thêm được khả năng không mong muốn ở bài #65.
(Bài 51 và 55 hiện đã giải quyết được yêu cầu bài toán, tuy vậy vẫn có khả năng bài #65 xảy ra.Đến đây vẫn là 99%.Nếu dùng được cách tạo key của chú @VetMini thì trọn vẹn)
 

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,518
Được thích
30,886
Điểm
9,718
Tuổi
59
Nơi ở
Gò Vấp
khả năng không mong muốn ở bài #65.
(Bài 51 và 55 hiện đã giải quyết được yêu cầu bài toán, tuy vậy vẫn có khả năng bài #65 xảy ra.Đến đây vẫn là 99%.Nếu dùng được cách tạo key của chú @VetMini thì trọn vẹn)
Bài 65 là viết để trả lời câu hỏi (yêu cầu) ở bài 64 chứ đâu phải để giải quyết yêu cầu chính? Yêu cầu chính là đã giải quyết bằng 55 và cách 2 bài 57.
code Dictionary của tôi và bác @VetMini là cùng thuật toán, chỉ khác thủ thuật dùng item mà thôi. Ngoài ra theo góp ý của bác ấy:
Theo tôi hiểu thì cộng như vậy sẽ bị trùng.
Cùng số nhưng khác thứ tự:
3+4+5 = 12
4+3+5 = 12
Khác số, cùng tổng:
2+4+6 = 12

Nếu tôi lập keys màu thì tôi cộng chuỗi
Join(Array(3, 4, 5), ".") = "3.4.5"
Nếu thứ tự không phân biệt (đỏ, cam, vàng coi như vàng, cam, đỏ) thì phải sắp xếp.
Khả năng khác số cùng tổng rất ít khả năng xảy ra khi con người tự chọn màu: Thường con người chủ quan chọn những màu khá khác biệt nhau thành 1 bộ.
Khả năng cùng màu nhưng khác thứ tự có thể xảy ra (cũng do con người: thích và chọn 1 số màu này, ít chọn màu khác)
Vậy thì đổi hết những dấu + thành dấu &:
PHP:
        TotalColor = SampleRng.Cells(i, 1).Interior.Color + _
            SampleRng.Cells(i, 2).Interior.Color + _
            SampleRng.Cells(i, 3).Interior.Color
        Dict.Add TotalColor, i
            '-->'
        TotalColor = SampleRng.Cells(i, 1).Interior.Color & _
            SampleRng.Cells(i, 2).Interior.Color & _
            SampleRng.Cells(i, 3).Interior.Color
        Dict.Add TotalColor, 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
Bài 65 là viết để trả lời câu hỏi (yêu cầu) ở bài 64 chứ đâu phải để giải quyết yêu cầu chính? Yêu cầu chính là đã giải quyết bằng 55 và cách 2 bài 57.
code Dictionary của tôi và bác @VetMini là cùng thuật toán, chỉ khác thủ thuật dùng item mà thôi. Ngoài ra theo góp ý của bác ấy:

Khả năng khác số cùng tổng rất ít khả năng xảy ra khi con người tự chọn màu: Thường con người chủ quan chọn những màu khá khác biệt nhau thành 1 bộ.
Khả năng cùng màu nhưng khác thứ tự có thể xảy ra (cũng do con người: thích và chọn 1 số màu này, ít chọn màu khác)
Vậy thì đổi hết những dấu + thành dấu &:
PHP:
        TotalColor = SampleRng.Cells(i, 1).Interior.Color + _
            SampleRng.Cells(i, 2).Interior.Color + _
            SampleRng.Cells(i, 3).Interior.Color
        Dict.Add TotalColor, i
            '-->'
        TotalColor = SampleRng.Cells(i, 1).Interior.Color & _
            SampleRng.Cells(i, 2).Interior.Color & _
            SampleRng.Cells(i, 3).Interior.Color
        Dict.Add TotalColor, i
Với cách tạo key ở bài #71 và bài #4 là tương đương nhau rồi phải không ạ.
Tuy vậy, khi đổi dấu "+" thành "&" để ghép vào bài #51 và #55 code vẫn chưa chay được chú Mỹ ạ. Mong chú xây lại bài #51,#55 với Kye đã chuyển dấu + thành dấu &.
 
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,518
Được thích
30,886
Điểm
9,718
Tuổi
59
Nơi ở
Gò Vấp
Tuy vậy, khi đổi dấu "+" thành "&" để ghép vào bài #51 và #55 code vẫn chưa chay được chú Mỹ ạ. Mong chú xây lại bài #51,#55 với Kye đã chuyển dấu + thành dấu &.
- Có 2 chỗ cần chuyển, chắc mới chuyển 1
- Chưa khai báo lại biến TotalColor thành String
PHP:
Sub CountColor2()
Dim Dict, SampleRng As Range, DataRng As Range
Dim TotalColor As String, RArr(), Tmp As Long, LastRw As Long
With Sheet1
    Set SampleRng = .Range("H5:J8")
    LastRw = .Cells(10000, 2).End(xlUp).Row
    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
        If Dict.Exists(TotalColor) Then
            Tmp = Dict.Item(TotalColor)
            RArr(Tmp, 1) = RArr(Tmp, 1) + 1
        End If
    Next
    .Range("K5").Resize(Dict.Count, 1) = RArr
End With
End Sub
Tuy nhiên nối chuỗi cũng sẽ bị trùng với những Interior.Color ngắn dài không đều
Có lẽ nối thêm ký tự phân cách như bác @VetMini:
PHP:
    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
        If Dict.Exists(TotalColor) Then
            Tmp = Dict.Item(TotalColor)
            RArr(Tmp, 1) = RArr(Tmp, 1) + 1
        End If
    Next
    .Range("K5").Resize(Dict.Count, 1) = RArr
 
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
- Có 2 chỗ cần chuyển, chắc mới chuyển 1
- Chưa khai báo lại biến TotalColor thành String
PHP:
Sub CountColor2()
Dim Dict, SampleRng As Range, DataRng As Range
Dim TotalColor As String, RArr(), Tmp As Long, LastRw As Long
With Sheet1
    Set SampleRng = .Range("H5:J8")
    LastRw = .Cells(10000, 2).End(xlUp).Row
    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
        If Dict.Exists(TotalColor) Then
            Tmp = Dict.Item(TotalColor)
            RArr(Tmp, 1) = RArr(Tmp, 1) + 1
        End If
    Next
    .Range("K5").Resize(Dict.Count, 1) = RArr
End With
End Sub
Tuy nhiên nối chuỗi cũng sẽ bị trùng với những Interior.Color ngắn dài không đều
Có lẽ nối thêm ký tự phân cách như bác @VetMini:
PHP:
    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
        If Dict.Exists(TotalColor) Then
            Tmp = Dict.Item(TotalColor)
            RArr(Tmp, 1) = RArr(Tmp, 1) + 1
        End If
    Next
    .Range("K5").Resize(Dict.Count, 1) = RArr
- Sự kết hợp code của 2 chú @ptm0412 @VetMini đã tạo ra tuyệt tác của của trí tuệ.
- Đến bây giờ :"Kính thưa toàn thể quý zị, kính thưa toàn thể bà con và quan viên hai họ" (các bác học về mảng và Dict thì seach:Kính thưa toàn thể quý zị, kính thưa toàn thể bà con và quan viên hai họ, có các bài từ trước những năm 2012). Đến bài #73 với cháu(em) đã đầy đủ về Dictionary trong VBA,đã trọn vẹn 100%.
Với các code của top này thì thỏa thê chế cháo.
- Dictionary vba mạnh khiếp thật.
Cháu cảm ơn hai chú,chúc hai chú luôn khỏe như "Dictionary", tràn đầy năng lượng và nhiệt huyết.
Em cảm ơn các bác!
 

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,518
Được thích
30,886
Điểm
9,718
Tuổi
59
Nơi ở
Gò Vấp
đã đầy đủ về Dictionary trong VBA,đã trọn vẹn 100%.
Coi chừng sa vào bước xe đổ của @Hoàng Nhật Phương, căn bản chưa vững mà túm lấy công cụ mạnh. Cụ thể là lỗi chưa biết bug để biết chỗ sai, chỗ sai không biết sửa, gợi ý sửa lại làm không đúng.
Ngoài ra nói về Dictionary, item của nó còn nhiều ứng dụng đáng nói, thí dụ như đối với 1 bài toán nào đó sẽ gán item bằng 1 mảng. Vài bữa lại tuyên bố 100% lần 3, lần 4, lần n thì quan viên 2 họ mắng cho, chứ chẳng phải mình lão chết tiệt mắng.
 

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
Coi chừng sa vào bước xe đổ của @Hoàng Nhật Phương, căn bản chưa vững mà túm lấy công cụ mạnh. Cụ thể là lỗi chưa biết bug để biết chỗ sai, chỗ sai không biết sửa, gợi ý sửa lại làm không đúng.
Ngoài ra nói về Dictionary, item của nó còn nhiều ứng dụng đáng nói, thí dụ như đối với 1 bài toán nào đó sẽ gán item bằng 1 mảng. Vài bữa lại tuyên bố 100% lần 3, lần 4, lần n thì quan viên 2 họ mắng cho, chứ chẳng phải mình lão chết tiệt mắng.
Lần đầu tiên ạ.
Nhưng cách đẻ ra key khó thiệt chú ạ. Nếu vậy đến đây hi vọng đc 50% về Dictionary. Còn 1/2 như chưa biết lúc nào sẽ gặp. Chú bao nhiều sân có gì chú chỉ cháu ít link về item là mảng chú nhé.
 
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
Dictionary không phải của VBA.
Rõ ràng lúc dựng object CreateObject("Scripting.Dictionary"), nó được ttham chiếu từ thư viện Scripting (Microsoft Scripting Runtime library).
Thư viện này nằm trong file ..\Windows\system32\scrrun.DLL (hoặc đại khái vậy) và hoàn toàn không có liên hệ gì đến VBA, Excel, hay Access cả.
 

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,518
Được thích
30,886
Điểm
9,718
Tuổi
59
Nơi ở
Gò Vấp
Lần đầu tiên ạ.
Nhưng cách đẻ ra key khó thiệt chú ạ. Nếu vậy đến đây hi vọng đc 50% về Dictionary. Còn 1/2 như chưa biết lúc nào sẽ gặp. Chú bao nhiều sân có gì chú chỉ cháu ít link về item là mảng chú nhé.
File dưới đây cùng 1 bài toán, 2 code dùng Dict khác nhau, 1 code dùng Dict với item là mảng, 1 code dùng Dict và 1 mảng kết quả nhưng item được gán và sử dụng linh hoạt.
Ghi chú: code 1 với item là mảng chậm hơn do gán xuống sheet nhiều lần hơn so với code 2 chỉ gán kết quả 1 lần.
Khuyến mãi ảnh cháu ngoại ngày mồng 1
1613634705160.png
 

File đính kèm

  • DicItemArray.xlsm
    418.2 KB · Đọc: 7

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
File dưới đây cùng 1 bài toán, 2 code dùng Dict khác nhau, 1 code dùng Dict với item là mảng, 1 code dùng Dict và 1 mảng kết quả nhưng item được gán và sử dụng linh hoạt.
Ghi chú: code 1 với item là mảng chậm hơn do gán xuống sheet nhiều lần hơn so với code 2 chỉ gán kết quả 1 lần.
Khuyến mãi ảnh cháu ngoại ngày mồng 1
View attachment 254255
Bé đáng yêu xinh xắn quá chú ạ!
Chú như ông Bụt trong diễn đàn vậy.
Cháu chúc 2 ông cháu lúc nào cũng hạnh phúc đáng yêu!
 
Quảng cáo
Top Bottom