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

Liên hệ QC
Cô Bé Dễ Thương

Cô Bé Dễ Thương

Thành viên thường trực
Tham gia
30/9/16
Bài viết
223
Được thích
48
Giới tính
Nữ
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: 18
Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
ptm0412 đã viết:
Đậ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
Nhấp chuột vào đây để mở rộng...
Cháu có thể hiểu đoạn này là loại bỏ kye không trùng phải không chú.
ptm0412 đã viết:
Này thì xử lý trồi

View attachment 254207
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
emgaimuarao đã viết:
Đú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ị?
Nhấp chuột vào đây để mở rộng...
Ủ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:

ptm0412 đã viết:
Pậy pạ nà. Bỏ cái trồi trồi đó là xong rồi
Nhấp chuột vào đây để mở rộng...
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 (@$%@
 
Upvote 0
emgaimuarao đã viết:
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.
Nhấp chuột vào đây để mở rộng...
Đã 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?

Hoàng Nhật Phương đã viết:
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
Nhấp chuột vào đây để mở rộng...
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:
Upvote 0
ptm0412 đã viết:
Đã 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
Nhấp chuột vào đây để mở rộng...
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ú ạ!
 
Upvote 0
emgaimuarao đã viết:
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ú ạ!
Nhấp chuột vào đây để mở rộng...
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:
Upvote 0
ptm0412 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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:
Upvote 0
Upvote 0
ptm0412 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
ptm0412 đã viết:
...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
...
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
ptm0412 đã viết:
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
Nhấp chuột vào đây để mở rộng...
ptm0412 đã viết:
Này thì xử lý trồi

View attachment 254207
Nhấp chuột vào đây để mở rộng...
- 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)
 
Upvote 0
emgaimuarao đã viết:
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)
Nhấp chuột vào đây để mở rộng...
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:
VetMini đã viết:
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.
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
ptm0412 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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:
Upvote 0
emgaimuarao đã viết:
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 &.
Nhấp chuột vào đây để mở rộng...
- 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:
Upvote 0
ptm0412 đã viết:
- 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
Nhấp chuột vào đây để mở rộng...
- 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!
 
Upvote 0
emgaimuarao đã viết:
đã đầy đủ về Dictionary trong VBA,đã trọn vẹn 100%.
Nhấp chuột vào đây để mở rộng...
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.
 
Upvote 0
ptm0412 đã viết:
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.
Nhấp chuột vào đây để mở rộ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:
Upvote 0
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ả.
 
Upvote 0
emgaimuarao đã viết:
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é.
Nhấp chuột vào đây để mở rộng...
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: 9
Upvote 0
ptm0412 đã viết:
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
Nhấp chuột vào đây để mở rộng...
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!
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

ongke0711
  • Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
11 12 13
Trả lời
246
Đọc
13K
trannguyen197
T
Tuấn Bụng Bự
  • Question
Tìm Bộ 8 số xuất hiện nhiều nhất trong random( 1 - 80)
2
Trả lời
28
Đọc
591
Tuấn Bụng Bự
Tuấn Bụng Bự
C
Chia sẻ: Kết quả xổ số Keno
    • Cười
    • Thích
Trả lời
9
Đọc
231
ptm0412
ptm0412
P
Tổng hợp dữ liệu từ các sheet theo chọn lọc
Trả lời
14
Đọc
261
ptm0412
ptm0412
B
Định dạng condition formatting, đếm hỗn hợp dữ liệu merge và không merge
Trả lời
7
Đọc
110
Hoàng Tuấn 868
H
T
Tối ưu hóa hàm lấy dữ liệu từ bảng Tổng sang bảng chi tiết
Trả lời
7
Đọc
208
Hoàng Tuấn 868
H
nguyenphuochien166
Cách Vlookup hoặc cách lấy thông tin dữ liệu có dấu mũ lũy thừa?
    • Cười
Trả lời
6
Đọc
105
tigertiger
tigertiger
T
Không đếm dữ liệu rỗng trong PivotTable
Trả lời
8
Đọc
1K
hoangtuaotrang_hp_vn
H
B
Lọc dữ liệu trùng, đếm số lần, tự tô màu theo điều kiện.
Trả lời
3
Đọc
114
batista911
B
C
Công thức tự nhập liệu số lượng nhập khi bị âm
Trả lời
1
Đọc
92
hoangtuaotrang_hp_vn
H
kimtanmap
  • Question
Nhờ viết code VBA Macro lập lại.
Trả lời
5
Đọc
155
kimtanmap
kimtanmap
dung09031989
Xin giúp công thức tô màu các ô phía sau khi kế hoạch đặt hàng thiếu so với tồn kho.?
Trả lời
1
Đọc
76
hoangtuaotrang_hp_vn
H
huynhnhu1234
Tìm giá vé máy bay một chiều và khứ hồi
Trả lời
0
Đọc
46
huynhnhu1234
huynhnhu1234
V
[Nhờ giúp đỡ] Cách tìm thời gian bị trùng trong excel ở nhiều thời gian khác nhau
Trả lời
7
Đọc
127
tranvansau278
T
N
Hàm tìm giá trị theo giờ vào - ra
Trả lời
6
Đọc
116
Nguyễn Linh hn94
N
zarra
Cần giúp tạo form in mã vạch cho vật tư theo SL cụ thể.
Trả lời
4
Đọc
163
zarra
zarra
Nguyễn Duy Tuân
  • Question
Chia sẻ ControlForOffice - Bộ công cụ điều khiển Office/Excel
    • Thích
6 7 8
Trả lời
148
Đọc
95K
leminhksvl
L
HeSanbi
  • Question
Lỗi VBA: Cài đặt thông số ForceVBALoadFromSource trong Registry để VBA biên dịch không bị lỗi
    • Cảm ơn
    • Thích
Trả lời
5
Đọc
296
anhdepjai
A
H
Hàm đếm số ngày thứ bảy và chủ nhật trong một khoảng thời gian
Trả lời
17
Đọc
20K
DeTong
D
D
  • Question
Xin cách sắp xếp dữ liệu theo thứ tự không làm hỏng link
Trả lời
7
Đọc
304
cantl
C
Xem thêm…

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom